{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Aura.Types
(
Package(..), pname, pprov, pver, dividePkgs
, Dep(..), parseDep, renderedDep
, Buildable(..)
, Prebuilt(..)
, SimplePkg(..), simplepkg, simplepkg'
, Flagable(..)
, VersionDemand(..), _VersionDemand
, InstallType(..)
, DepError(..)
, Failure(..)
, Language(..)
, PkgName(..)
, PkgGroup(..)
, Provides(..)
, PackagePath(..)
, Pkgbuild(..)
, Environment
, User(..)
) where
import Control.Error.Util (hush)
import Data.Aeson (FromJSONKey, ToJSONKey)
import Data.Bifunctor (Bifunctor(..))
import Data.Bitraversable
import Data.Generics.Product (field, super)
import Data.Semigroup.Foldable (Foldable1(..))
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NES
import Data.Text.Prettyprint.Doc hiding (list, space)
import Data.Text.Prettyprint.Doc.Render.Terminal
import Data.These (These(..))
import Data.Versions hiding (Traversal')
import Lens.Micro
import RIO hiding (try)
import qualified RIO.Text as T
import System.Path (Absolute, Path, takeFileName, toUnrootedFilePath)
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) = pb ^. field @"name"
pname (FromAUR b) = b ^. field @"name"
pprov :: Package -> Provides
pprov (FromRepo pb) = pb ^. field @"provides"
pprov (FromAUR b) = b ^. field @"provides"
pver :: Package -> Versioning
pver (FromRepo pb) = pb ^. field @"version"
pver (FromAUR b) = b ^. field @"version"
dividePkgs :: NESet Package -> These (NESet Prebuilt) (NESet Buildable)
dividePkgs = bimap NES.fromList NES.fromList . partNonEmpty f . NES.toList
where
f :: Package -> These Prebuilt Buildable
f (FromRepo p) = This p
f (FromAUR b) = That b
partNonEmpty :: (a -> These b c) -> NonEmpty a -> These (NonEmpty b) (NonEmpty c)
partNonEmpty f = foldMap1 (bimap pure pure . f)
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 (a ^. super @SimplePkg) (b ^. super @SimplePkg)
compare (FromRepo a) (FromAUR b) = compare (a ^. super @SimplePkg) (b ^. super @SimplePkg)
data Buildable = Buildable { name :: !PkgName
, version :: !Versioning
, base :: !PkgName
, provides :: !Provides
, deps :: ![Dep]
, pkgbuild :: !Pkgbuild
, isExplicit :: !Bool } deriving (Eq, Ord, Show, Generic)
data Prebuilt = Prebuilt { name :: !PkgName
, version :: !Versioning
, base :: !PkgName
, provides :: !Provides } deriving (Eq, Ord, Show, Generic)
data Dep = Dep { name :: !PkgName
, demand :: !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 -> pure Anything
| otherwise -> 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) = (n ^. field @"name") <> 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 { name :: !PkgName, version :: !Versioning } deriving (Eq, Ord, Show, Generic)
simplepkg :: PackagePath -> Maybe SimplePkg
simplepkg (PackagePath t) = uncurry SimplePkg <$> bitraverse hush hush (parse n "name" t', parse v "version" t')
where t' = T.pack . toUnrootedFilePath $ 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 { path :: Path Absolute } deriving (Eq, Generic)
instance Ord PackagePath where
compare a b | nameA /= nameB = compare (path a) (path b)
| otherwise = compare verA verB
where (nameA, verA) = f a
(nameB, verB) = f b
f = ((^? _Just . field @"name") &&& (^? _Just . field @"version")) . simplepkg
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
deriving (Eq, Enum, Bounded, Ord, Show)
data DepError = NonExistant 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 { name :: Text }
deriving stock (Eq, Ord, Show, Generic)
deriving newtype (Flagable, ToJSONKey, FromJSONKey, IsString)
newtype PkgGroup = PkgGroup { group :: Text }
deriving stock (Eq, Ord, Show, Generic)
deriving newtype (Flagable)
newtype Provides = Provides { provides :: PkgName } deriving (Eq, Ord, Show, Generic)