diff --git a/ats-pkg.cabal b/ats-pkg.cabal --- a/ats-pkg.cabal +++ b/ats-pkg.cabal @@ -1,11 +1,12 @@ cabal-version: 2.0 name: ats-pkg -version: 3.0.0.2 +version: 3.0.0.4 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018 Vanessa McHale maintainer: vamchale@gmail.com author: Vanessa McHale +tested-with: ghc ==8.4.3 bug-reports: https://github.com/vmchale/atspkg/issues synopsis: A build tool for ATS description: @@ -125,7 +126,11 @@ bytestring -any, composition-prelude >=1.3.0.0, binary -any, - text -any + text -any, + mtl -any + + if flag(development) + cpp-options: -DDEBUG if !os(windows) build-depends: diff --git a/dhall/atspkg-prelude.dhall b/dhall/atspkg-prelude.dhall --- a/dhall/atspkg-prelude.dhall +++ b/dhall/atspkg-prelude.dhall @@ -101,6 +101,34 @@ let plainDeps = λ(x : Text) → { _1 = x, _2 = { lower = none, upper = none } } in +let eqDeps = λ(x : { name : Text, version : List Natural }) → + { _1 = x.name + , _2 = { lower = [ x.version ] + : Optional (List Natural) + , upper = [ x.version ] + : Optional (List Natural) + } + } +in + +let lowerDeps = λ(x : { name : Text, version : List Natural }) → + { _1 = x.name + , _2 = { lower = [ x.version ] + : Optional (List Natural) + , upper = none + } + } +in + +let upperDeps = λ(x : { name : Text, version : List Natural }) → + { _1 = x.name + , _2 = { lower = none + , upper = [ x.version ] + : Optional (List Natural) + } + } +in + let mapPlainDeps = λ(x : List Text) → map Text LibDep plainDeps x in @@ -276,6 +304,8 @@ , staticLib = staticLib , default = default , plainDeps = plainDeps +, lowerDeps = lowerDeps +, upperDeps = upperDeps , mapPlainDeps = mapPlainDeps , src = src , mapSrc = mapSrc diff --git a/internal/Quaalude.cpphs b/internal/Quaalude.cpphs --- a/internal/Quaalude.cpphs +++ b/internal/Quaalude.cpphs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} module Quaalude ( hex , bool @@ -30,6 +31,7 @@ , exitWith , showVersion , traverse_ + , nubSpecial , ExitCode (ExitSuccess) , MonadIO (..) -- * Miscellaneous @@ -117,12 +119,18 @@ , each , (&) , (%~) + +#ifdef DEBUG + , traceShowId + , traceShow +#endif ) where import Control.Arrow hiding ((<+>)) import Control.Composition import Control.Monad import Control.Monad.IO.Class +import Control.Monad.State.Lazy import Data.Binary import Data.Bool (bool) import Data.ByteString.Lazy (ByteString) @@ -132,6 +140,9 @@ import Data.Maybe (fromMaybe) import Data.Text.Lazy (Text, pack, unpack) import Data.Version (showVersion) +#ifdef DEBUG +import Debug.Trace (traceShow, traceShowId) +#endif import Development.Shake hiding (getEnv) import Development.Shake.FilePath import Dhall hiding (Text, bool) @@ -149,7 +160,7 @@ #endif import System.Process as X import System.Process.Ext -import Text.PrettyPrint.ANSI.Leijen hiding (bool, (<$>), (), (<>)) +import Text.PrettyPrint.ANSI.Leijen hiding (bool, group, (<$>), (), (<>)) infixr 5 <#> @@ -160,6 +171,10 @@ makeExecutable :: FilePath -> IO () makeExecutable = flip setFileMode ownerModes #endif + +nubSpecial :: (Ord a) => [[a]] -> [[a]] +nubSpecial = pure . rmDups . join + where rmDups = fmap head . group . sort makeExe :: String makeExe = case os of diff --git a/src/Language/ATS/Package/Build.hs b/src/Language/ATS/Package/Build.hs --- a/src/Language/ATS/Package/Build.hs +++ b/src/Language/ATS/Package/Build.hs @@ -292,7 +292,7 @@ (_, cfgBin') <- cfgBin need [ cfgBin', flags, ".atspkg" "config" ] v'' <- getVerbosity - liftIO $ fetchDeps v'' (ccFromString cc') setup (unpack . fst <$> ds) (unpack . fst <$> cdps) (unpack . fst <$> bdeps) cfgBin' atslibSetup False *> writeFile out "" + liftIO $ fetchDeps v'' (ccFromString cc') setup (first unpack <$> ds) (first unpack <$> cdps) (first unpack <$> bdeps) cfgBin' atslibSetup False *> writeFile out "" let bins = toTgt tgt . target <$> bs setTargets rs bins mt diff --git a/src/Language/ATS/Package/Dependency.hs b/src/Language/ATS/Package/Dependency.hs --- a/src/Language/ATS/Package/Dependency.hs +++ b/src/Language/ATS/Package/Dependency.hs @@ -32,9 +32,9 @@ fetchDeps :: Verbosity -- ^ Shake verbosity -> CCompiler -- ^ C compiler to use -> [IO ()] -- ^ Setup steps that can be performed concurrently - -> [String] -- ^ ATS dependencies - -> [String] -- ^ C Dependencies - -> [String] -- ^ ATS build dependencies + -> [(String, ATSConstraint)] -- ^ ATS dependencies + -> [(String, ATSConstraint)] -- ^ C Dependencies + -> [(String, ATSConstraint)] -- ^ ATS build dependencies -> FilePath -- ^ Path to configuration file -> SetupScript -- ^ How to install an ATS library -> Bool -- ^ Whether to perform setup anyhow. diff --git a/src/Language/ATS/Package/PackageSet.hs b/src/Language/ATS/Package/PackageSet.hs --- a/src/Language/ATS/Package/PackageSet.hs +++ b/src/Language/ATS/Package/PackageSet.hs @@ -10,6 +10,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Dependency +import Data.List (nubBy) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T @@ -31,8 +32,12 @@ where g (Just d) = ("description:" <+> text (unpack d) <#>) g Nothing = id +sameName :: [ATSDependency] -> [ATSDependency] +sameName = reverse . nubBy go . reverse + where go = on (==) libName + instance Pretty ATSPackageSet where - pretty (ATSPackageSet ds) = fold (punctuate hardline (pretty <$> ds)) + pretty (ATSPackageSet ds) = fold (punctuate hardline (pretty <$> sameName ds)) displayList :: String -> IO () displayList = putDoc . pretty <=< listDeps True @@ -47,7 +52,7 @@ setBuildPlan :: FilePath -- ^ Filepath for cache inside @.atspkg@ -> DepSelector -> String -- ^ URL of package set to use. - -> [String] -- ^ Libraries we want + -> [(String, ATSConstraint)] -- ^ Libraries we want -> IO [[ATSDependency]] setBuildPlan p getDeps url deps = do b <- doesFileExist depCache @@ -64,12 +69,15 @@ mkBuildPlan :: DepSelector -> ATSPackageSet - -> [String] + -> [(String, ATSConstraint)] -> DepM [[ATSDependency]] -mkBuildPlan getDeps aps@(ATSPackageSet ps) = finalize . resolve . fmap (asDep getDeps) <=< stringBuildPlan +mkBuildPlan getDeps aps@(ATSPackageSet ps) names = finalize . fmap (nubSpecial) . resolve . fmap (selfDepend . asDep getDeps) <=< stringBuildPlan $ names where finalize = fmap (fmap (fmap (lookupVersions aps))) resolve = resolveDependencies (atsPkgsToPkgs libDeps aps) - stringBuildPlan names = sequence [ lookup' x libs | x <- names ] + selfDepend (Dependency ln ds v) = case lookup ln names of + Just v' -> Dependency ln ((ln, canonicalize v') : ds) (traceShowId v) + Nothing -> Dependency ln ds v + stringBuildPlan names' = sequence [ lookup' x libs | (x, _) <- names' ] where libs = (unpack . libName &&& id) <$> ps lookup' k vs = case lookup k vs of Just x -> Right x