arch-hs-0.2.0.0: app/Main.hs
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Main (main) where
import qualified Algebra.Graph.AdjacencyMap.Algorithm as G
import qualified Algebra.Graph.Labelled.AdjacencyMap as GL
import Args
import qualified Colourista as C
import Conduit
import Control.Monad (filterM)
import Data.IORef (IORef, newIORef)
import Data.List.NonEmpty (toList)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Distribution.ArchHs.Aur (Aur, aurToIO, isInAur)
import Distribution.ArchHs.Community
( defaultCommunityPath,
isInCommunity,
loadProcessedCommunity,
)
import Distribution.ArchHs.Core
( cabalToPkgBuild,
getDependencies,
)
import Distribution.ArchHs.Exception
import Distribution.ArchHs.Hackage
( getPackageFlag,
insertDB,
loadHackageDB,
lookupHackagePath,
parseCabalFile,
)
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Local
import Distribution.ArchHs.PP
( prettyDeps,
prettyFlagAssignments,
prettyFlags,
prettySkip,
prettySolvedPkgs,
)
import qualified Distribution.ArchHs.PkgBuild as N
import Distribution.ArchHs.Types
import Distribution.ArchHs.Utils (getTwo)
import Distribution.Hackage.DB (HackageDB)
import System.Directory
( createDirectoryIfMissing,
doesFileExist,
)
import System.FilePath (takeFileName)
app ::
Members '[Embed IO, State (Set.Set PackageName), CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, Aur, WithMyErr] r =>
PackageName ->
FilePath ->
Bool ->
[String] ->
Bool ->
Sem r ()
app target path aurSupport skip uusi = do
(deps, ignored) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target
inCommunity <- isInCommunity target
when inCommunity $ throw $ TargetExist target ByCommunity
if aurSupport
then do
inAur <- isInAur target
when inAur $ throw $ TargetExist target ByAur
else return ()
let grouped = groupDeps deps
namesFromSolved x = x ^.. each . pkgName <> x ^.. each . pkgDeps . each . depName
allNames = nub $ namesFromSolved grouped
communityProvideList <- (<> ghcLibList) <$> filterM isInCommunity allNames
let fillProvidedPkgs provideList provider = mapC (\x -> if (x ^. pkgName) `elem` provideList then ProvidedPackage (x ^. pkgName) provider else x)
fillProvidedDeps provideList provider = mapC (pkgDeps %~ each %~ (\y -> if y ^. depName `elem` provideList then y & depProvider .~ (Just provider) else y))
filledByCommunity =
runConduitPure $
yieldMany grouped
.| fillProvidedPkgs communityProvideList ByCommunity
.| fillProvidedDeps communityProvideList ByCommunity
.| sinkList
toBePacked1 = filledByCommunity ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True)
(filledByBoth, toBePacked2) <- do
embed . when aurSupport $ C.infoMessage "Start searching AUR..."
aurProvideList <- if aurSupport then filterM (\n -> do embed $ C.infoMessage ("Searching " <> (T.pack $ unPackageName n)); isInAur n) $ toBePacked1 ^.. each . pkgName else return []
let filledByBoth =
if aurSupport
then
runConduitPure $
yieldMany filledByCommunity
.| fillProvidedPkgs aurProvideList ByAur
.| fillProvidedDeps aurProvideList ByAur
.| sinkList
else filledByCommunity
toBePacked2 =
if aurSupport
then filledByBoth ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True)
else toBePacked1
return (filledByBoth, toBePacked2)
embed $ C.infoMessage "Solved target:"
embed $ putStrLn . prettySolvedPkgs $ filledByBoth
embed $ C.infoMessage "Recommended package order (from topological sort):"
let vertexesToBeRemoved = filledByBoth ^.. each . filtered (\case ProvidedPackage _ _ -> True; _ -> False) ^.. each . pkgName
removeSelfCycle g = foldr (\n acc -> GL.removeEdge n n acc) g $ toBePacked2 ^.. each . pkgName
newGraph = GL.induce (`notElem` vertexesToBeRemoved) deps
flattened <- case G.topSort . GL.skeleton $ removeSelfCycle $ newGraph of
Left c -> throw . CyclicExist $ toList c
Right x -> return x
embed $ putStrLn . prettyDeps . reverse $ flattened
flags <- filter (\(_, l) -> length l /= 0) <$> mapM (\n -> (n,) <$> getPackageFlag n) flattened
embed $
when (length flags /= 0) $ do
C.infoMessage "Detected flags from targets (their values will keep default unless you specify):"
putStrLn . prettyFlags $ flags
let dry = path == ""
embed $ when dry $ C.warningMessage "You didn't pass -o, PKGBUILD files will not be generated."
when (not dry) $
mapM_
( \solved -> do
pkgBuild <- cabalToPkgBuild solved (Set.toList ignored) uusi
let pName = "haskell-" <> N._pkgName pkgBuild
dir = path </> pName
fileName = dir </> "PKGBUILD"
txt = N.applyTemplate pkgBuild
embed $ createDirectoryIfMissing True dir
embed $ writeFile fileName txt
embed $ C.infoMessage $ "Write file: " <> T.pack fileName
)
toBePacked2
-----------------------------------------------------------------------------
runApp ::
HackageDB ->
CommunityDB ->
Map.Map PackageName FlagAssignment ->
Bool ->
FilePath ->
IORef (Set.Set PackageName) ->
Sem '[CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, State (Set.Set PackageName), Aur, WithMyErr, Embed IO, Final IO] a ->
IO (Either MyException a)
runApp hackage community flags stdout path ref =
runFinal
. embedToFinal
. errorToIOFinal
. aurToIO
. runStateIORef ref
. runTrace stdout path
. evalState Map.empty
. runReader flags
. runReader hackage
. runReader community
runTrace :: Member (Embed IO) r => Bool -> FilePath -> Sem (Trace ': r) a -> Sem r a
runTrace stdout path = interpret $ \case
Trace m -> do
when stdout (embed $ putStrLn m)
when (not $ null path) (embed $ appendFile path (m ++ "\n"))
-----------------------------------------------------------------------------
main :: IO ()
main = printHandledIOException $
do
Options {..} <- runArgsParser
let traceToFile = not $ null optFileTrace
when (traceToFile) $ do
C.infoMessage $ "Trace will be dumped to " <> (T.pack optFileTrace) <> "."
exist <- doesFileExist optFileTrace
when exist $
C.warningMessage $ "File " <> (T.pack optFileTrace) <> " already existed, overwrite it."
let useDefaultHackage = isInfixOf "YOUR_HACKAGE_MIRROR" $ optHackagePath
useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath
when useDefaultHackage $ C.skipMessage "You didn't pass -h, use hackage index file from default path."
when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path."
let isFlagEmpty = optFlags == Map.empty
isSkipEmpty = optSkip == []
when isFlagEmpty $ C.skipMessage "You didn't pass -f, different flag assignments may make difference in dependency resolving."
when (not isFlagEmpty) $ do
C.infoMessage "You assigned flags:"
putStrLn . prettyFlagAssignments $ optFlags
when (not isSkipEmpty) $ do
C.infoMessage "You chose to skip:"
putStrLn $ prettySkip optSkip
when optAur $ C.infoMessage "You passed -a, searching AUR may takes a long time."
when optUusi $ C.infoMessage "You passed --uusi, uusi will become makedepends of each package."
hackage <- loadHackageDB =<< if useDefaultHackage then lookupHackagePath else return optHackagePath
C.infoMessage "Loading hackage..."
let isExtraEmpty = optExtraCabalPath == []
when (not isExtraEmpty) $
C.infoMessage $ "You added " <> (T.pack . intercalate ", " $ map takeFileName optExtraCabalPath) <> " as extra cabal file(s), starting parsing right now."
parsedExtra <- mapM parseCabalFile optExtraCabalPath
let newHackage = foldr (\x acc -> x `insertDB` acc) hackage parsedExtra
community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath
C.infoMessage "Loading community.db..."
C.infoMessage "Start running..."
empty <- newIORef Set.empty
runApp newHackage community optFlags optStdoutTrace optFileTrace empty (app optTarget optOutputDir optAur optSkip optUusi) & printAppResult
-----------------------------------------------------------------------------
groupDeps :: GL.AdjacencyMap (Set.Set DependencyType) PackageName -> [SolvedPackage]
groupDeps graph =
fmap
( \(name, deps) ->
SolvedPackage name $ fmap (uncurry . flip $ SolvedDependency Nothing) deps
)
$ result <> aloneChildren
where
result =
fmap ((\(a, b, c) -> (head b, zip a c)) . unzip3)
. groupBy (\x y -> uncurry (==) (getTwo _2 x y))
. fmap (_1 %~ Set.toList)
. GL.edgeList
$ graph
parents = fmap fst result
children = mconcat $ fmap (\(_, ds) -> fmap snd ds) result
-- Maybe 'G.vertexSet' is a better choice
aloneChildren = nub $ zip (filter (`notElem` parents) children) (repeat [])