{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Aura.Types
(
Package(..), pname, pprov, pver, dividePkgs
, Dep(..), parseDep, renderedDep
, Buildable(..)
, Prebuilt(..)
, SimplePkg(..), simplepkg, simplepkg', bToSP, pToSP
, Flagable(..)
, VersionDemand(..), _VersionDemand
, InstallType(..)
, DepError(..)
, Failure(..)
, Language(..)
, PkgName(..)
, PkgGroup(..)
, Provides(..)
, PackagePath, packagePath, ppPath
, Pkgbuild(..)
, Environment
, User(..)
) where
import Aura.Utils
import Data.Aeson (FromJSONKey, ToJSONKey)
import Data.Bitraversable
import Data.Text.Prettyprint.Doc hiding (list, space)
import Data.Text.Prettyprint.Doc.Render.Terminal
import Data.Versions hiding (Traversal')
import Lens.Micro
import RIO hiding (try)
import RIO.FilePath
import qualified RIO.Text as T
import Text.Megaparsec
import Text.Megaparsec.Char
class Flagable a where
asFlag :: a -> [Text]
instance Flagable Text where
asFlag t = [t]
instance (Foldable f, Flagable a) => Flagable (f a) where
asFlag = foldMap asFlag
data Package = FromRepo Prebuilt | FromAUR Buildable deriving (Eq)
pname :: Package -> PkgName
pname (FromRepo pb) = pName pb
pname (FromAUR b) = bName b
pprov :: Package -> Provides
pprov (FromRepo pb) = pProvides pb
pprov (FromAUR b) = bProvides b
pver :: Package -> Versioning
pver (FromRepo pb) = pVersion pb
pver (FromAUR b) = bVersion b
dividePkgs :: NonEmpty Package -> These (NonEmpty Prebuilt) (NonEmpty Buildable)
dividePkgs = partNonEmpty f
where
f :: Package -> These Prebuilt Buildable
f (FromRepo p) = This p
f (FromAUR b) = That b
instance Ord Package where
compare (FromAUR a) (FromAUR b) = compare a b
compare (FromRepo a) (FromRepo b) = compare a b
compare (FromAUR a) (FromRepo b) = compare (bToSP a) (pToSP b)
compare (FromRepo a) (FromAUR b) = compare (pToSP a) (bToSP b)
data Buildable = Buildable
{ bName :: !PkgName
, bVersion :: !Versioning
, bBase :: !PkgName
, bProvides :: !Provides
, bDeps :: ![Dep]
, bPkgbuild :: !Pkgbuild
, bIsExplicit :: !Bool }
deriving (Eq, Ord, Show, Generic)
data Prebuilt = Prebuilt
{ pName :: !PkgName
, pVersion :: !Versioning
, pBase :: !PkgName
, pProvides :: !Provides }
deriving (Eq, Ord, Show, Generic)
data Dep = Dep
{ dName :: !PkgName
, dDemand :: !VersionDemand }
deriving (Eq, Ord, Show, Generic)
parseDep :: Text -> Maybe Dep
parseDep = hush . parse dep "dep"
where dep = Dep <$> n <*> v
n = PkgName <$> takeWhile1P Nothing (\c -> c /= '<' && c /= '>' && c /= '=')
v = do
end <- atEnd
if end
then pure Anything
else choice [ char '<' *> fmap LessThan versioning'
, string ">=" *> fmap AtLeast versioning'
, char '>' *> fmap MoreThan versioning'
, char '=' *> fmap MustBe versioning'
, pure Anything ]
renderedDep :: Dep -> Text
renderedDep (Dep n ver) = pnName n <> asT ver
where
asT :: VersionDemand -> Text
asT (LessThan v) = "<" <> prettyV v
asT (AtLeast v) = ">=" <> prettyV v
asT (MoreThan v) = ">" <> prettyV v
asT (MustBe v) = "=" <> prettyV v
asT Anything = ""
data VersionDemand = LessThan Versioning
| AtLeast Versioning
| MoreThan Versioning
| MustBe Versioning
| Anything
deriving (Eq, Ord)
instance Show VersionDemand where
show (LessThan v) = T.unpack $ "<" <> prettyV v
show (AtLeast v) = T.unpack $ ">=" <> prettyV v
show (MoreThan v) = T.unpack $ ">" <> prettyV v
show (MustBe v) = T.unpack $ "=" <> prettyV v
show Anything = "Anything"
_VersionDemand :: Traversal' VersionDemand Versioning
_VersionDemand f (LessThan v) = LessThan <$> f v
_VersionDemand f (AtLeast v) = AtLeast <$> f v
_VersionDemand f (MoreThan v) = MoreThan <$> f v
_VersionDemand f (MustBe v) = MustBe <$> f v
_VersionDemand _ p = pure p
data InstallType = Pacman PkgName | Build Buildable deriving (Eq)
data SimplePkg = SimplePkg
{ spName :: !PkgName
, spVersion :: !Versioning }
deriving (Eq, Ord, Show, Generic)
bToSP :: Buildable -> SimplePkg
bToSP b = SimplePkg (bName b) (bVersion b)
pToSP :: Prebuilt -> SimplePkg
pToSP p = SimplePkg (pName p) (pVersion p)
simplepkg :: PackagePath -> Maybe SimplePkg
simplepkg (PackagePath t) =
uncurry SimplePkg <$> bitraverse hush hush (parse n "name" t', parse v "version" t')
where
t' :: Text
t' = T.pack $ takeFileName t
n :: Parsec Void Text PkgName
n = PkgName . T.pack <$> manyTill anySingle (try finished)
finished = char '-' *> lookAhead digitChar
v = manyTill anySingle (try finished) *> ver
ver = try (fmap Ideal semver' <* post) <|> try (fmap General version' <* post) <|> fmap Complex mess'
post = char '-' *> (string "x86_64" <|> string "any") *> string ".pkg.tar.xz"
simplepkg' :: Text -> Maybe SimplePkg
simplepkg' = hush . parse parser "name-and-version"
where parser = SimplePkg <$> (PkgName <$> takeWhile1P Nothing (/= ' ')) <*> (space *> versioning')
newtype PackagePath = PackagePath { ppPath :: FilePath }
deriving (Eq, Generic)
instance Ord PackagePath where
compare a b | nameA /= nameB = compare (ppPath a) (ppPath b)
| otherwise = compare verA verB
where
(nameA, verA) = f a
(nameB, verB) = f b
f :: PackagePath -> (Maybe PkgName, Maybe Versioning)
f = (fmap spName &&& fmap spVersion) . simplepkg
packagePath :: FilePath -> Maybe PackagePath
packagePath fp = bool Nothing (Just $ PackagePath fp) $ isAbsolute fp
newtype Pkgbuild = Pkgbuild { pkgbuild :: ByteString }
deriving (Eq, Ord, Show, Generic)
data Language = English
| Japanese
| Polish
| Croatian
| Swedish
| German
| Spanish
| Portuguese
| French
| Russian
| Italian
| Serbian
| Norwegian
| Indonesia
| Chinese
| Esperanto
| Dutch
deriving (Eq, Enum, Bounded, Ord, Show)
data DepError = NonExistant PkgName PkgName
| VerConflict (Doc AnsiStyle)
| Ignored (Doc AnsiStyle)
| BrokenProvides PkgName Provides PkgName
newtype Failure = Failure { failure :: Language -> Doc AnsiStyle }
instance Exception Failure
instance Show Failure where
show (Failure _) = "There was some failure."
type Environment = Map Text Text
newtype User = User { user :: Text }
deriving (Eq, Show, Generic)
newtype PkgName = PkgName { pnName :: Text }
deriving stock (Eq, Ord, Show, Generic)
deriving newtype (Flagable, ToJSONKey, FromJSONKey, IsString)
newtype PkgGroup = PkgGroup { pgGroup :: Text }
deriving stock (Eq, Ord, Show, Generic)
deriving newtype (Flagable)
newtype Provides = Provides { provides :: PkgName }
deriving (Eq, Ord, Show, Generic)