{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Language.ATS.Package.PackageSet ( ATSPackageSet (..)
, setBuildPlan
, displayList
) where
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
import Language.ATS.Package.Error
import Language.ATS.Package.Type
import Quaalude
newtype ATSPackageSet = ATSPackageSet { _atsPkgSet :: [ ATSDependency ] }
deriving (FromDhall)
atsPkgSet :: Lens' ATSPackageSet [ATSDependency]
atsPkgSet f s = fmap (\x -> s { _atsPkgSet = x }) (f (_atsPkgSet s))
instance Pretty Version where
pretty v = text (show v)
instance Pretty ATSDependency where
pretty (ATSDependency ln _ url md v _ _ _ _) = dullyellow (text (unpack ln)) <#> indent 4 (g md "url:" <+> text (unpack url) <#> "version:" <+> pretty v) <> hardline
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 <$> sameName ds))
displayList :: String -> IO ()
displayList = putDoc . pretty <=< listDeps True
listDeps :: Bool
-> String
-> IO ATSPackageSet
listDeps b = fmap s . input auto . T.pack
where s = bool id s' b
s' = over atsPkgSet (sortBy (compare `on` libName))
setBuildPlan :: FilePath
-> DepSelector
-> Maybe String
-> String
-> [(String, ATSConstraint)]
-> IO [[ATSDependency]]
setBuildPlan p getDeps mStr url deps = do
b <- doesFileExist depCache
b' <- shouldWrite mStr (".atspkg" </> "args")
bool setBuildPlan' (decode <$> BSL.readFile depCache) (b && b')
where depCache = ".atspkg/buildplan-" ++ p
setBuildPlan' = do
pkgSet <- listDeps False url
case mkBuildPlan getDeps pkgSet deps of
Left x -> resolutionFailed x
Right x -> createDirectoryIfMissing True ".atspkg" *>
BSL.writeFile depCache (encode x) $>
x
mkBuildPlan :: DepSelector
-> ATSPackageSet
-> [(String, ATSConstraint)]
-> DepM [[ATSDependency]]
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)
selfDepend (Dependency ln ds v) = case lookup ln names of
Just v' -> Dependency ln ((ln, canonicalize v') : ds) 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
Nothing -> Left (NotPresent k)
canonicalize :: ATSConstraint -> Constraint Version
canonicalize (ATSConstraint (Just l) Nothing) = GreaterThanEq l
canonicalize (ATSConstraint Nothing (Just u)) = LessThanEq u
canonicalize (ATSConstraint Nothing Nothing) = None
canonicalize (ATSConstraint (Just l) (Just u)) = Bounded (GreaterThanEq l) (LessThanEq u)
asDep :: DepSelector
-> ATSDependency
-> Dependency
asDep getDeps d@ATSDependency{..} = Dependency (unpack libName) (g <$> getDeps d) libVersion
where g = unpack *** canonicalize
atsPkgsToPkgs :: DepSelector
-> ATSPackageSet
-> PackageSet Dependency
atsPkgsToPkgs getDeps (ATSPackageSet deps) = PackageSet $ foldr (.) id inserts mempty
where inserts = insert <$> deps
insert dep = M.insertWith
(\_ -> S.insert (asDep getDeps dep))
(unpack $ libName dep)
(S.singleton (asDep getDeps dep))
lookupVersions :: ATSPackageSet -> Dependency -> ATSDependency
lookupVersions (ATSPackageSet deps) (Dependency name _ v) = head (filter f deps)
where f = (&&) <$> matchName <*> matchVersion
libName' = unpack . libName
matchName = (== name) . libName'
matchVersion = (== v) . libVersion