{-# Language StandaloneDeriving, PatternGuards, CPP, OverloadedStrings #-}

module CabalBounds.Main
   ( cabalBounds
   ) where

import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult)
import Distribution.Parsec.Warning (PWarning)
import qualified Distribution.PackageDescription.PrettyPrint as PP
import Distribution.Simple.Configure (tryGetConfigStateFile)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)
import Distribution.Utils.Path (makeSymbolicPath)
import qualified Distribution.Simple.LocalBuildInfo as BI
import qualified Distribution.Package as P
import qualified Distribution.Simple.PackageIndex as PX
import qualified Distribution.InstalledPackageInfo as PI
import qualified Distribution.Version as V
import qualified CabalBounds.Args as A
import qualified CabalBounds.Bound as B
import qualified CabalBounds.Sections as S
import qualified CabalBounds.Dependencies as DP
import qualified CabalBounds.Drop as DR
import qualified CabalBounds.Update as U
import qualified CabalBounds.Dump as DU
import qualified CabalBounds.HaskellPlatform as HP
import CabalBounds.Types
import qualified CabalLenses as CL
import qualified System.IO.Strict as SIO
import System.FilePath ((</>))
import System.Directory (getCurrentDirectory)
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
import Control.Monad.IO.Class
import Control.Lens
import qualified Data.HashMap.Strict as HM
import Data.List (foldl', sortBy)
import Data.Function (on)
import Data.Char (toLower)
import Data.Maybe (fromMaybe, catMaybes)
import qualified Data.Aeson as Aeson
import Data.Aeson.Lens
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.List as L
import Text.Read (readMaybe)


#if MIN_VERSION_Cabal(1,22,0) == 0
import Distribution.Simple.Configure (ConfigStateFileErrorType(..))
#endif

#if MIN_VERSION_Cabal(1,22,0) && MIN_VERSION_Cabal(1,22,1) == 0
import Control.Lens
#endif

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif


type Error = String
type SetupConfigFile = FilePath
type PlanFile = FilePath
type LibraryFile = FilePath
type CabalFile = FilePath


cabalBounds :: A.Args -> IO (Maybe Error)
cabalBounds :: Args -> IO (Maybe Error)
cabalBounds args :: Args
args@A.Drop {} =
   Either Error () -> Maybe Error
forall a b. Either a b -> Maybe a
leftToJust (Either Error () -> Maybe Error)
-> IO (Either Error ()) -> IO (Maybe Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT Error IO () -> IO (Either Error ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
      Error
cabalFile <- Maybe Error -> ExceptT Error IO Error
findCabalFile (Maybe Error -> ExceptT Error IO Error)
-> Maybe Error -> ExceptT Error IO Error
forall a b. (a -> b) -> a -> b
$ Args -> Maybe Error
A.cabalFile Args
args
      GenericPackageDescription
pkgDescrp <- Error -> ExceptT Error IO GenericPackageDescription
packageDescription Error
cabalFile
      let pkgDescrp' :: GenericPackageDescription
pkgDescrp' = DropBound
-> [Section]
-> Dependencies
-> GenericPackageDescription
-> GenericPackageDescription
DR.drop (Args -> DropBound
B.boundOfDrop Args
args) (Args -> GenericPackageDescription -> [Section]
S.sections Args
args GenericPackageDescription
pkgDescrp) (Args -> Dependencies
DP.dependencies Args
args) GenericPackageDescription
pkgDescrp
      let outputFile :: Error
outputFile = Error -> Maybe Error -> Error
forall a. a -> Maybe a -> a
fromMaybe Error
cabalFile (Args -> Maybe Error
A.output Args
args)
      IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Error -> Error -> IO ()
writeFile Error
outputFile (GenericPackageDescription -> Error
showGenericPackageDescription GenericPackageDescription
pkgDescrp'))

cabalBounds args :: Args
args@A.Update {} =
   Either Error () -> Maybe Error
forall a b. Either a b -> Maybe a
leftToJust (Either Error () -> Maybe Error)
-> IO (Either Error ()) -> IO (Maybe Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT Error IO () -> IO (Either Error ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
      Error
cabalFile <- Maybe Error -> ExceptT Error IO Error
findCabalFile (Maybe Error -> ExceptT Error IO Error)
-> Maybe Error -> ExceptT Error IO Error
forall a b. (a -> b) -> a -> b
$ Args -> Maybe Error
A.cabalFile Args
args
      GenericPackageDescription
pkgDescrp <- Error -> ExceptT Error IO GenericPackageDescription
packageDescription Error
cabalFile
      let haskelPlatform :: Error
haskelPlatform = Args -> Error
A.haskellPlatform Args
args
          libFile :: Error
libFile        = Args -> Error
A.fromFile Args
args
          configFile :: Maybe Error
configFile     = Args -> Maybe Error
A.setupConfigFile Args
args
          planFile :: Maybe Error
planFile       = Args -> Maybe Error
A.planFile Args
args
      LibraryMap
libs      <- Error
-> Error
-> Maybe Error
-> Maybe Error
-> Error
-> ExceptT Error IO LibraryMap
libraries Error
haskelPlatform Error
libFile Maybe Error
configFile Maybe Error
planFile Error
cabalFile
      let pkgDescrp' :: GenericPackageDescription
pkgDescrp' = UpdateBound
-> [Section]
-> Dependencies
-> LibraryMap
-> GenericPackageDescription
-> GenericPackageDescription
U.update (Args -> UpdateBound
B.boundOfUpdate Args
args) (Args -> GenericPackageDescription -> [Section]
S.sections Args
args GenericPackageDescription
pkgDescrp) (Args -> Dependencies
DP.dependencies Args
args) LibraryMap
libs GenericPackageDescription
pkgDescrp
      let outputFile :: Error
outputFile = Error -> Maybe Error -> Error
forall a. a -> Maybe a -> a
fromMaybe Error
cabalFile (Args -> Maybe Error
A.output Args
args)
      IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Error -> Error -> IO ()
writeFile Error
outputFile (GenericPackageDescription -> Error
showGenericPackageDescription GenericPackageDescription
pkgDescrp'))

cabalBounds args :: Args
args@A.Dump {} =
   Either Error () -> Maybe Error
forall a b. Either a b -> Maybe a
leftToJust (Either Error () -> Maybe Error)
-> IO (Either Error ()) -> IO (Maybe Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT Error IO () -> IO (Either Error ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
      [Error]
cabalFiles <- if [Error] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Error] -> Bool) -> [Error] -> Bool
forall a b. (a -> b) -> a -> b
$ Args -> [Error]
A.cabalFiles Args
args
                       then (Error -> [Error] -> [Error]
forall a. a -> [a] -> [a]
: []) (Error -> [Error])
-> ExceptT Error IO Error -> ExceptT Error IO [Error]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Error -> ExceptT Error IO Error
findCabalFile Maybe Error
forall a. Maybe a
Nothing
                       else [Error] -> ExceptT Error IO [Error]
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Error] -> ExceptT Error IO [Error])
-> [Error] -> ExceptT Error IO [Error]
forall a b. (a -> b) -> a -> b
$ Args -> [Error]
A.cabalFiles Args
args

      [GenericPackageDescription]
pkgDescrps <- [Error] -> ExceptT Error IO [GenericPackageDescription]
packageDescriptions [Error]
cabalFiles
      let libs :: Libraries
libs = Libraries -> Libraries
sortLibraries (Libraries -> Libraries) -> Libraries -> Libraries
forall a b. (a -> b) -> a -> b
$ Dependencies -> [GenericPackageDescription] -> Libraries
DU.dump (Args -> Dependencies
DP.dependencies Args
args) [GenericPackageDescription]
pkgDescrps
      case Args -> Maybe Error
A.output Args
args of
           Just Error
file -> IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Error -> Error -> IO ()
writeFile Error
file (Libraries -> Error
prettyPrint Libraries
libs)
           Maybe Error
Nothing   -> IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Error -> IO ()
putStrLn (Libraries -> Error
prettyPrint Libraries
libs))

cabalBounds args :: Args
args@A.Libs {} =
   Either Error () -> Maybe Error
forall a b. Either a b -> Maybe a
leftToJust (Either Error () -> Maybe Error)
-> IO (Either Error ()) -> IO (Maybe Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT Error IO () -> IO (Either Error ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
      Error
cabalFile <- Maybe Error -> ExceptT Error IO Error
findCabalFile (Maybe Error -> ExceptT Error IO Error)
-> Maybe Error -> ExceptT Error IO Error
forall a b. (a -> b) -> a -> b
$ Args -> Maybe Error
A.cabalFile Args
args
      let haskelPlatform :: Error
haskelPlatform = Args -> Error
A.haskellPlatform Args
args
          libFile :: Error
libFile        = Args -> Error
A.fromFile Args
args
          configFile :: Maybe Error
configFile     = Args -> Maybe Error
A.setupConfigFile Args
args
          planFile :: Maybe Error
planFile       = Args -> Maybe Error
A.planFile Args
args
      Libraries
libs <- Libraries -> Libraries
sortLibraries (Libraries -> Libraries)
-> (LibraryMap -> Libraries) -> LibraryMap -> Libraries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibraryMap -> Libraries
toList (LibraryMap -> Libraries)
-> ExceptT Error IO LibraryMap -> ExceptT Error IO Libraries
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error
-> Error
-> Maybe Error
-> Maybe Error
-> Error
-> ExceptT Error IO LibraryMap
libraries Error
haskelPlatform Error
libFile Maybe Error
configFile Maybe Error
planFile Error
cabalFile
      let libs' :: Libraries
libs' = Libraries
libs Libraries
-> Getting (Endo Libraries) Libraries Library -> Libraries
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo Libraries) Libraries Library
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
IndexedTraversal Int Libraries Libraries Library Library
traversed Getting (Endo Libraries) Libraries Library
-> ((Library -> Const (Endo Libraries) Library)
    -> Library -> Const (Endo Libraries) Library)
-> Getting (Endo Libraries) Libraries Library
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> Traversal' Library Library
DP.filterLibrary (Args -> Dependencies
DP.dependencies Args
args)
      case Args -> Maybe Error
A.output Args
args of
           Just Error
file -> IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Error -> Error -> IO ()
writeFile Error
file (Libraries -> Error
prettyPrint Libraries
libs')
           Maybe Error
Nothing   -> IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Error -> IO ()
putStrLn (Libraries -> Error
prettyPrint Libraries
libs'))


cabalBounds args :: Args
args@A.Format {} =
   Either Error () -> Maybe Error
forall a b. Either a b -> Maybe a
leftToJust (Either Error () -> Maybe Error)
-> IO (Either Error ()) -> IO (Maybe Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT Error IO () -> IO (Either Error ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (do
      Error
cabalFile <- Maybe Error -> ExceptT Error IO Error
findCabalFile (Maybe Error -> ExceptT Error IO Error)
-> Maybe Error -> ExceptT Error IO Error
forall a b. (a -> b) -> a -> b
$ Args -> Maybe Error
A.cabalFile Args
args
      GenericPackageDescription
pkgDescrp <- Error -> ExceptT Error IO GenericPackageDescription
packageDescription Error
cabalFile
      let outputFile :: Error
outputFile = Error -> Maybe Error -> Error
forall a. a -> Maybe a -> a
fromMaybe Error
cabalFile (Args -> Maybe Error
A.output Args
args)
      IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ Error -> Error -> IO ()
writeFile Error
outputFile (GenericPackageDescription -> Error
showGenericPackageDescription GenericPackageDescription
pkgDescrp))


sortLibraries :: Libraries -> Libraries
sortLibraries :: Libraries -> Libraries
sortLibraries = (Library -> Library -> Ordering) -> Libraries -> Libraries
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Error -> Error -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Error -> Error -> Ordering)
-> (Library -> Error) -> Library -> Library -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Char -> Char) -> Error -> Error
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Error -> Error) -> (Library -> Error) -> Library -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> Error
forall a b. (a, b) -> a
fst))


prettyPrint :: Libraries -> String
prettyPrint :: Libraries -> Error
prettyPrint []     = Error
"[]"
prettyPrint (Library
l:Libraries
ls) =
   Error
"[ " Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Library -> Error
forall a. Show a => a -> Error
show Library
l Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
"\n" Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ (Error -> Library -> Error) -> Error -> Libraries -> Error
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Error
str Library
l -> Error
str Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
", " Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Library -> Error
forall a. Show a => a -> Error
show Library
l Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
"\n") Error
"" Libraries
ls Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
"]\n";


findCabalFile :: Maybe CabalFile -> ExceptT Error IO CabalFile
findCabalFile :: Maybe Error -> ExceptT Error IO Error
findCabalFile Maybe Error
Nothing = do
   Error
curDir <- IO Error -> ExceptT Error IO Error
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Error
getCurrentDirectory
   Error -> ExceptT Error IO Error
CL.findCabalFile Error
curDir

findCabalFile (Just Error
file) = Error -> ExceptT Error IO Error
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Error
file


packageDescription :: FilePath -> ExceptT Error IO GenericPackageDescription
packageDescription :: Error -> ExceptT Error IO GenericPackageDescription
packageDescription Error
file = do
   ByteString
contents <- IO ByteString -> ExceptT Error IO ByteString
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT Error IO ByteString)
-> IO ByteString -> ExceptT Error IO ByteString
forall a b. (a -> b) -> a -> b
$ Error -> IO ByteString
BS.readFile Error
file
   let ([PWarning]
warnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
result) = ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ParseResult GenericPackageDescription
 -> ([PWarning],
     Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription ByteString
contents
   IO () -> ExceptT Error IO ()
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Error IO ()) -> IO () -> ExceptT Error IO ()
forall a b. (a -> b) -> a -> b
$ [PWarning] -> IO ()
showWarnings [PWarning]
warnings
   case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
result of
        Left (Maybe Version
_, NonEmpty PError
errors) -> Error -> ExceptT Error IO GenericPackageDescription
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error IO GenericPackageDescription)
-> Error -> ExceptT Error IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ NonEmpty PError -> Error
forall a. Show a => a -> Error
show NonEmpty PError
errors
        Right GenericPackageDescription
pkgDescrp  -> GenericPackageDescription
-> ExceptT Error IO GenericPackageDescription
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GenericPackageDescription
pkgDescrp

   where
      showWarnings :: [PWarning] -> IO ()
      showWarnings :: [PWarning] -> IO ()
showWarnings [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      showWarnings [PWarning]
ws = Error -> IO ()
putStrLn (Error -> IO ()) -> Error -> IO ()
forall a b. (a -> b) -> a -> b
$ Error
"cabal-bounds: " Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ (Error -> [Error] -> Error
forall a. [a] -> [[a]] -> [a]
L.intercalate Error
", " ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$ (PWarning -> Error) -> [PWarning] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
map PWarning -> Error
forall a. Show a => a -> Error
show [PWarning]
ws)


packageDescriptions :: [FilePath] -> ExceptT Error IO [GenericPackageDescription]
packageDescriptions :: [Error] -> ExceptT Error IO [GenericPackageDescription]
packageDescriptions []    = Error -> ExceptT Error IO [GenericPackageDescription]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Error
"Missing cabal file"
packageDescriptions [Error]
files = (Error -> ExceptT Error IO GenericPackageDescription)
-> [Error] -> ExceptT Error IO [GenericPackageDescription]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Error -> ExceptT Error IO GenericPackageDescription
packageDescription [Error]
files


libraries :: HP.HPVersion -> LibraryFile -> Maybe SetupConfigFile -> Maybe PlanFile -> CabalFile -> ExceptT Error IO LibraryMap
libraries :: Error
-> Error
-> Maybe Error
-> Maybe Error
-> Error
-> ExceptT Error IO LibraryMap
libraries Error
"" Error
"" (Just Error
confFile) Maybe Error
_ Error
_ = do
   Error -> ExceptT Error IO LibraryMap
librariesFromSetupConfig Error
confFile

libraries Error
"" Error
"" Maybe Error
_ (Just Error
planFile) Error
_ = do
   Error -> ExceptT Error IO LibraryMap
librariesFromPlanFile Error
planFile

libraries Error
"" Error
"" Maybe Error
Nothing Maybe Error
Nothing Error
cabalFile = do
   Maybe Error
newDistDir <- IO (Maybe Error) -> ExceptT Error IO (Maybe Error)
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Error) -> ExceptT Error IO (Maybe Error))
-> IO (Maybe Error) -> ExceptT Error IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ Error -> IO (Maybe Error)
CL.findNewDistDir Error
cabalFile
   case Maybe Error
newDistDir of
        Just Error
newDistDir -> Error -> ExceptT Error IO LibraryMap
librariesFromPlanFile (Error -> ExceptT Error IO LibraryMap)
-> Error -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ Error
newDistDir Error -> Error -> Error
</> Error
"cache" Error -> Error -> Error
</> Error
"plan.json"
        Maybe Error
Nothing         -> do
           Maybe Error
distDir <- IO (Maybe Error) -> ExceptT Error IO (Maybe Error)
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Error) -> ExceptT Error IO (Maybe Error))
-> IO (Maybe Error) -> ExceptT Error IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ Error -> IO (Maybe Error)
CL.findDistDir Error
cabalFile
           case Maybe Error
distDir of
                Just Error
distDir -> Error -> ExceptT Error IO LibraryMap
librariesFromSetupConfig (Error -> ExceptT Error IO LibraryMap)
-> Error -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ Error
distDir Error -> Error -> Error
</> Error
"setup-config"
                Maybe Error
Nothing      -> Error -> ExceptT Error IO LibraryMap
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Error
"Couldn't find 'dist-newstyle' nor 'dist' directory! Have you already build the cabal project?"

libraries Error
hpVersion Error
libFile Maybe Error
_ Maybe Error
_ Error
_ = do
   LibraryMap
hpLibs       <- Error -> ExceptT Error IO LibraryMap
haskellPlatformLibraries Error
hpVersion
   LibraryMap
libsFromFile <- Error -> ExceptT Error IO LibraryMap
librariesFromFile Error
libFile
   LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LibraryMap -> ExceptT Error IO LibraryMap)
-> LibraryMap -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ LibraryMap -> LibraryMap -> LibraryMap
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
HM.union LibraryMap
hpLibs LibraryMap
libsFromFile


librariesFromFile :: LibraryFile -> ExceptT Error IO LibraryMap
librariesFromFile :: Error -> ExceptT Error IO LibraryMap
librariesFromFile Error
""      = LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LibraryMap
forall k v. HashMap k v
HM.empty
librariesFromFile Error
libFile = do
   Error
contents <- IO Error -> ExceptT Error IO Error
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Error -> ExceptT Error IO Error)
-> IO Error -> ExceptT Error IO Error
forall a b. (a -> b) -> a -> b
$ Error -> IO Error
SIO.readFile Error
libFile
   Error -> ExceptT Error IO LibraryMap
forall {m :: * -> *} {e}.
(Monad m, IsString e) =>
Error -> ExceptT e m LibraryMap
libsFrom Error
contents
   where
      libsFrom :: Error -> ExceptT e m LibraryMap
libsFrom Error
contents
         | [(Libraries
libs, Error
_)] <- ReadS Libraries
forall a. Read a => ReadS a
reads Error
contents :: [([(String, [Int])], String)]
         = LibraryMap -> ExceptT e m LibraryMap
forall a. a -> ExceptT e m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LibraryMap -> ExceptT e m LibraryMap)
-> LibraryMap -> ExceptT e m LibraryMap
forall a b. (a -> b) -> a -> b
$ [(Error, Version)] -> LibraryMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ((Library -> (Error, Version)) -> Libraries -> [(Error, Version)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Error
pkgName, [Int]
versBranch) -> (Error
pkgName, [Int] -> Version
V.mkVersion [Int]
versBranch)) Libraries
libs)

         | Bool
otherwise
         = e -> ExceptT e m LibraryMap
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE e
"Invalid format of library file given to '--fromfile'. Expected file with content of type '[(String, [Int])]'."


haskellPlatformLibraries :: HP.HPVersion -> ExceptT Error IO LibraryMap
haskellPlatformLibraries :: Error -> ExceptT Error IO LibraryMap
haskellPlatformLibraries Error
hpVersion =
   case Error
hpVersion of
        Error
""         -> LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LibraryMap
forall k v. HashMap k v
HM.empty
        Error
"current"  -> LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LibraryMap -> ExceptT Error IO LibraryMap)
-> ([(Error, Version)] -> LibraryMap)
-> [(Error, Version)]
-> ExceptT Error IO LibraryMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Error, Version)] -> LibraryMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Error, Version)] -> ExceptT Error IO LibraryMap)
-> [(Error, Version)] -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ [(Error, Version)]
HP.currentLibraries
        Error
"previous" -> LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LibraryMap -> ExceptT Error IO LibraryMap)
-> ([(Error, Version)] -> LibraryMap)
-> [(Error, Version)]
-> ExceptT Error IO LibraryMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Error, Version)] -> LibraryMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Error, Version)] -> ExceptT Error IO LibraryMap)
-> [(Error, Version)] -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ [(Error, Version)]
HP.previousLibraries
        Error
version | Just [(Error, Version)]
libs <- Error -> Maybe [(Error, Version)]
HP.librariesOf Error
version -> LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LibraryMap -> ExceptT Error IO LibraryMap)
-> ([(Error, Version)] -> LibraryMap)
-> [(Error, Version)]
-> ExceptT Error IO LibraryMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Error, Version)] -> LibraryMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Error, Version)] -> ExceptT Error IO LibraryMap)
-> [(Error, Version)] -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ [(Error, Version)]
libs
                | Bool
otherwise                           -> Error -> ExceptT Error IO LibraryMap
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error IO LibraryMap)
-> Error -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ Error
"Invalid haskell platform version '" Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
version Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
"'"


librariesFromSetupConfig :: SetupConfigFile -> ExceptT Error IO LibraryMap
librariesFromSetupConfig :: Error -> ExceptT Error IO LibraryMap
librariesFromSetupConfig Error
""       = LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LibraryMap
forall k v. HashMap k v
HM.empty
librariesFromSetupConfig Error
confFile = do
   Either ConfigStateFileError LocalBuildInfo
binfo <- IO (Either ConfigStateFileError LocalBuildInfo)
-> ExceptT Error IO (Either ConfigStateFileError LocalBuildInfo)
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ConfigStateFileError LocalBuildInfo)
 -> ExceptT Error IO (Either ConfigStateFileError LocalBuildInfo))
-> IO (Either ConfigStateFileError LocalBuildInfo)
-> ExceptT Error IO (Either ConfigStateFileError LocalBuildInfo)
forall a b. (a -> b) -> a -> b
$ Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetConfigStateFile Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (Error -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir). Error -> SymbolicPath from to
makeSymbolicPath Error
confFile)
   case Either ConfigStateFileError LocalBuildInfo
binfo of
        Left ConfigStateFileError
e   -> Error -> ExceptT Error IO LibraryMap
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error IO LibraryMap)
-> Error -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ ConfigStateFileError -> Error
forall a. Show a => a -> Error
show ConfigStateFileError
e
        Right LocalBuildInfo
bi -> LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LibraryMap -> ExceptT Error IO LibraryMap)
-> LibraryMap -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> LibraryMap
buildInfoLibs LocalBuildInfo
bi
   where
      buildInfoLibs :: LocalBuildInfo -> LibraryMap
      buildInfoLibs :: LocalBuildInfo -> LibraryMap
buildInfoLibs = [(Error, Version)] -> LibraryMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
                    ([(Error, Version)] -> LibraryMap)
-> (LocalBuildInfo -> [(Error, Version)])
-> LocalBuildInfo
-> LibraryMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, [InstalledPackageInfo]) -> (Error, Version))
-> [(PackageName, [InstalledPackageInfo])] -> [(Error, Version)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PackageName
pkg, [InstalledPackageInfo]
v) -> (PackageName -> Error
P.unPackageName PackageName
pkg, [InstalledPackageInfo] -> Version
newestVersion [InstalledPackageInfo]
v))
                    ([(PackageName, [InstalledPackageInfo])] -> [(Error, Version)])
-> (LocalBuildInfo -> [(PackageName, [InstalledPackageInfo])])
-> LocalBuildInfo
-> [(Error, Version)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, [InstalledPackageInfo]) -> Bool)
-> [(PackageName, [InstalledPackageInfo])]
-> [(PackageName, [InstalledPackageInfo])]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Bool
not (Bool -> Bool)
-> ([InstalledPackageInfo] -> Bool)
-> [InstalledPackageInfo]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([InstalledPackageInfo] -> Bool)
-> ((PackageName, [InstalledPackageInfo])
    -> [InstalledPackageInfo])
-> (PackageName, [InstalledPackageInfo])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd)
                    ([(PackageName, [InstalledPackageInfo])]
 -> [(PackageName, [InstalledPackageInfo])])
-> (LocalBuildInfo -> [(PackageName, [InstalledPackageInfo])])
-> LocalBuildInfo
-> [(PackageName, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIndex InstalledPackageInfo
-> [(PackageName, [InstalledPackageInfo])]
forall a. PackageIndex a -> [(PackageName, [a])]
PX.allPackagesByName (PackageIndex InstalledPackageInfo
 -> [(PackageName, [InstalledPackageInfo])])
-> (LocalBuildInfo -> PackageIndex InstalledPackageInfo)
-> LocalBuildInfo
-> [(PackageName, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalBuildInfo -> PackageIndex InstalledPackageInfo
BI.installedPkgs

      newestVersion :: [PI.InstalledPackageInfo] -> V.Version
      newestVersion :: [InstalledPackageInfo] -> Version
newestVersion = [Version] -> Version
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Version] -> Version)
-> ([InstalledPackageInfo] -> [Version])
-> [InstalledPackageInfo]
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledPackageInfo -> Version)
-> [InstalledPackageInfo] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> Version
P.pkgVersion (PackageIdentifier -> Version)
-> (InstalledPackageInfo -> PackageIdentifier)
-> InstalledPackageInfo
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> PackageIdentifier
PI.sourcePackageId)


librariesFromPlanFile :: PlanFile -> ExceptT Error IO LibraryMap
librariesFromPlanFile :: Error -> ExceptT Error IO LibraryMap
librariesFromPlanFile Error
planFile = do
   ByteString
contents <- IO ByteString -> ExceptT Error IO ByteString
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT Error IO ByteString)
-> IO ByteString -> ExceptT Error IO ByteString
forall a b. (a -> b) -> a -> b
$ Error -> IO ByteString
LBS.readFile Error
planFile
   let json :: Maybe Value
json = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
contents :: Maybe Aeson.Value
   case Maybe Value
json of
        Just Value
json -> do
           -- get all ids: ["bytestring-0.10.6.0-2362d1f36f12553920ce3710ae4a4ecb432374f4e5feb33a61b7414b43605a0df", ...]
           let ids :: [Text]
ids = Value
json Value -> Getting (Endo [Text]) Value Text -> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"install-plan" ((Value -> Const (Endo [Text]) Value)
 -> Value -> Const (Endo [Text]) Value)
-> Getting (Endo [Text]) Value Text
-> Getting (Endo [Text]) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Value -> Const (Endo [Text]) (Vector Value))
-> Value -> Const (Endo [Text]) Value
forall t. AsValue t => Prism' t (Vector Value)
Prism' Value (Vector Value)
_Array ((Vector Value -> Const (Endo [Text]) (Vector Value))
 -> Value -> Const (Endo [Text]) Value)
-> ((Text -> Const (Endo [Text]) Text)
    -> Vector Value -> Const (Endo [Text]) (Vector Value))
-> Getting (Endo [Text]) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (Endo [Text]) Value)
-> Vector Value -> Const (Endo [Text]) (Vector Value)
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
IndexedTraversal Int (Vector Value) (Vector Value) Value Value
traversed ((Value -> Const (Endo [Text]) Value)
 -> Vector Value -> Const (Endo [Text]) (Vector Value))
-> Getting (Endo [Text]) Value Text
-> (Text -> Const (Endo [Text]) Text)
-> Vector Value
-> Const (Endo [Text]) (Vector Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"id" ((Value -> Const (Endo [Text]) Value)
 -> Value -> Const (Endo [Text]) Value)
-> Getting (Endo [Text]) Value Text
-> Getting (Endo [Text]) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Text]) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
           let libs :: [(Error, Version)]
libs = [Maybe (Error, Version)] -> [(Error, Version)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Error, Version)] -> [(Error, Version)])
-> [Maybe (Error, Version)] -> [(Error, Version)]
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe (Error, Version))
-> [Text] -> [Maybe (Error, Version)]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Maybe (Error, Version)
parseLibrary [Text]
ids
           LibraryMap -> ExceptT Error IO LibraryMap
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LibraryMap -> ExceptT Error IO LibraryMap)
-> ([(Error, Version)] -> LibraryMap)
-> [(Error, Version)]
-> ExceptT Error IO LibraryMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Error, Version)] -> LibraryMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Error, Version)] -> ExceptT Error IO LibraryMap)
-> [(Error, Version)] -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ [(Error, Version)]
libs

        Maybe Value
Nothing   -> Error -> ExceptT Error IO LibraryMap
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error IO LibraryMap)
-> Error -> ExceptT Error IO LibraryMap
forall a b. (a -> b) -> a -> b
$ Error
"Couldn't parse json file '" Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
planFile Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ Error
"'"
   where
      parseLibrary :: Text -> Maybe (LibName, V.Version)
      parseLibrary :: Text -> Maybe (Error, Version)
parseLibrary Text
text =
         case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"-" Text
text of
              (Text
_, Text
"")         -> Maybe (Error, Version)
forall a. Maybe a
Nothing
              (Text
_, Text
"inplace")  -> Maybe (Error, Version)
forall a. Maybe a
Nothing
              (Text
before, Text
after) ->
                 case Text -> Maybe Version
parseVersion Text
after of
                      Just Version
vers -> (Error, Version) -> Maybe (Error, Version)
forall a. a -> Maybe a
Just (Text -> Error
T.unpack (Text -> Error) -> (Text -> Text) -> Text -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
stripSuffix Text
"-" (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
before, Version
vers)
                      Maybe Version
_         -> Text -> Maybe (Error, Version)
parseLibrary (Text -> Maybe (Error, Version)) -> Text -> Maybe (Error, Version)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
stripSuffix Text
"-" Text
before

      parseVersion :: Text -> Maybe V.Version
      parseVersion :: Text -> Maybe Version
parseVersion Text
text =
         case [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Int) -> [Text] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (Error -> Maybe Int
forall a. Read a => Error -> Maybe a
readMaybe (Error -> Maybe Int) -> (Text -> Error) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
T.unpack) ([Text] -> [Maybe Int]) -> [Text] -> [Maybe Int]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
text of
              []   -> Maybe Version
forall a. Maybe a
Nothing
              [Int]
nums -> Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ [Int] -> Version
V.mkVersion [Int]
nums

      stripSuffix :: Text -> Text -> Text
      stripSuffix :: Text -> Text -> Text
stripSuffix Text
suffix Text
text = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
text (Text -> Text -> Maybe Text
T.stripSuffix Text
suffix Text
text)


leftToJust :: Either a b -> Maybe a
leftToJust :: forall a b. Either a b -> Maybe a
leftToJust = (a -> Maybe a) -> (b -> Maybe a) -> Either a b -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Maybe a
forall a. a -> Maybe a
Just (Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing)


showGenericPackageDescription :: GenericPackageDescription -> String
showGenericPackageDescription :: GenericPackageDescription -> Error
showGenericPackageDescription =
#if MIN_VERSION_Cabal(1,22,1)
   GenericPackageDescription -> Error
PP.showGenericPackageDescription
#elif MIN_VERSION_Cabal(1,22,0)
   PP.showGenericPackageDescription . clearTargetBuildDepends
   where
      clearTargetBuildDepends pkgDescrp =
         pkgDescrp & CL.allBuildInfo . CL.targetBuildDependsL .~ []
#else
   ensureLastIsNewline . PP.showGenericPackageDescription
   where
      ensureLastIsNewline xs =
         if last xs == '\n' then xs else xs ++ "\n"
#endif


#if MIN_VERSION_Cabal(1,22,0) == 0
deriving instance Show ConfigStateFileErrorType
#endif