module Debian.Debianize.Atoms
( Atoms
, verbosity
, dryRun
, validate
, debAction
, flags
, warning
, compilerVersion
, packageDescription
, buildDir
, dataDir
, compiler
, extraLibMap
, execMap
, cabalFlagAssignments
, debianNameMap
, epochMap
, description
, executable
, serverInfo
, website
, backups
, apacheSite
, missingDependencies
, utilsPackageName
, sourcePackageName
, revision
, debVersion
, maintainer
, packageInfo
, omitLTDeps
, noProfilingLibrary
, noDocumentationLibrary
, copyright
, sourceArchitecture
, binaryArchitectures
, sourcePriority
, binaryPriorities
, sourceSection
, binarySections
, buildDeps
, buildDepsIndep
, depends
, conflicts
, replaces
, provides
, extraDevDeps
, rulesHead
, rulesFragments
, postInst
, postRm
, preInst
, preRm
, compat
, sourceFormat
, watch
, changelog
, comments
, control
, standards
, logrotateStanza
, link
, install
, installTo
, installData
, file
, installCabalExec
, installCabalExecTo
, installDir
, installInit
, intermediateFiles
) where
import Data.Char (toLower)
import Data.Generics (Data, Typeable)
import Data.Lens.Lazy (Lens, lens, getL, modL)
import Data.Map as Map (Map, fold, foldWithKey, insertWith, empty, insert)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Set as Set (Set, maxView, empty, union, singleton, fold, insert)
import Data.Text (Text)
import Data.Version (Version, showVersion)
import Debian.Changes (ChangeLog)
import Debian.Debianize.ControlFile (SourceDebDescription(standardsVersion), newSourceDebDescription)
import Debian.Debianize.Types (PackageInfo(..), Site(..), Server(..), InstallFile(..), DebAction(..))
import Debian.Debianize.Types.VersionSplits (VersionSplits)
import Debian.Orphans ()
import Debian.Policy (PackageArchitectures, SourceFormat, PackagePriority, Section, StandardsVersion)
import Debian.Relation (SrcPkgName, BinPkgName, Relations, Relation(..))
import Debian.Version (DebianVersion)
import Distribution.License (License)
import Distribution.Package (PackageName(PackageName), PackageIdentifier(..))
import Distribution.PackageDescription as Cabal (PackageDescription(package), FlagName, PackageDescription)
import Distribution.Simple.Compiler (Compiler)
import Prelude hiding (init, unlines, log)
import System.FilePath ((</>))
import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr)
data DebAtomKey
= Source
| Binary BinPkgName
deriving (Eq, Ord, Data, Typeable, Show)
data DebAtom
= NoDocumentationLibrary
| NoProfilingLibrary
| CompilerVersion Version
| DHPackageDescription PackageDescription
| DHCompiler Compiler
| BuildDir FilePath
| DataDir FilePath
| DebSourceFormat SourceFormat
| DebWatch Text
| DHIntermediate FilePath Text
| DebRulesHead Text
| DebRulesFragment Text
| Warning Text
| UtilsPackageName BinPkgName
| DebChangeLog ChangeLog
| DebLogComments [[Text]]
| DHMaintainer NameAddr
| DHCabalFlagAssignments (Set (FlagName, Bool))
| DHFlags Flags
| DebRevision String
| OmitLTDeps
| DebVersion DebianVersion
| DebianNameMap (Map PackageName VersionSplits)
| SourcePackageName SrcPkgName
| BuildDep Relations
| BuildDepIndep Relations
| MissingDependency BinPkgName
| ExtraLibMapping String Relations
| ExecMapping String Relations
| EpochMapping PackageName Int
| DebPackageInfo PackageInfo
| DebCompat Int
| DebCopyright (Either License Text)
| DebControl SourceDebDescription
| DHApacheSite String FilePath Text
| DHLogrotateStanza Text
| DHLink FilePath FilePath
| DHPostInst Text
| DHPostRm Text
| DHPreInst Text
| DHPreRm Text
| DHArch PackageArchitectures
| DHPriority PackagePriority
| DHSection Section
| DHDescription Text
| DHInstall FilePath FilePath
| DHInstallTo FilePath FilePath
| DHInstallData FilePath FilePath
| DHFile FilePath Text
| DHInstallCabalExec String FilePath
| DHInstallCabalExecTo String FilePath
| DHInstallDir FilePath
| DHInstallInit Text
| DHExecutable InstallFile
| DHServer Server
| DHWebsite Site
| DHBackups String
| Depends Relation
| Conflicts Relation
| Provides Relation
| Replaces Relation
| DevDepends Relation
deriving (Eq, Ord, Show, Typeable)
data Flags = Flags
{
verbosity_ :: Int
, dryRun_ :: Bool
, validate_ :: Bool
, debAction_ :: DebAction
} deriving (Eq, Ord, Show)
newtype Atoms = Atoms (Map DebAtomKey (Set DebAtom)) deriving (Eq, Show)
instance Monoid Atoms where
mempty = Atoms mempty
mappend a b = foldAtoms insertAtom a b
verbosity :: Lens Atoms Int
verbosity = lens (\ a -> verbosity_ (getL flags a)) (\ b a -> modL flags (\ x -> x {verbosity_ = b}) a)
dryRun :: Lens Atoms Bool
dryRun = lens (\ a -> dryRun_ (getL flags a)) (\ b a -> modL flags (\ x -> x {dryRun_ = b}) a)
validate :: Lens Atoms Bool
validate = lens (\ a -> validate_ (getL flags a)) (\ b a -> modL flags (\ x -> x {validate_ = b}) a)
debAction :: Lens Atoms DebAction
debAction = lens (\ a -> debAction_ (getL flags a)) (\ b a -> modL flags (\ x -> x {debAction_ = b}) a)
flags :: Lens Atoms Flags
flags = lens g s
where
g atoms = fromMaybe defaultFlags $ foldAtoms from Nothing atoms
where
from Source (DHFlags x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x')
from Source (DHFlags x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DHFlags) x)) atoms
where
f Source (DHFlags y) = Just y
f _ _ = Nothing
warning :: Lens Atoms (Set Text)
warning = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (Warning t) x = Set.insert t x
from _ _ x = x
s x atoms = Set.fold (\ text atoms' -> insertAtom Source (Warning text) atoms') (deleteAtoms p atoms) x
where
p Source (Warning _) = True
p _ _ = False
compilerVersion :: Lens Atoms (Maybe Version)
compilerVersion = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (CompilerVersion x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')
from Source (CompilerVersion x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . CompilerVersion) x)) atoms
where
f Source (CompilerVersion y) = Just y
f _ _ = Nothing
packageDescription :: Lens Atoms (Maybe PackageDescription)
packageDescription = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DHPackageDescription x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DHPackageDescription x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPackageDescription) x)) atoms
where
f Source (DHPackageDescription y) = Just y
f _ _ = Nothing
buildDir :: Lens Atoms (Maybe FilePath)
buildDir = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (BuildDir x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (BuildDir x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . BuildDir) x)) atoms
where
f Source (BuildDir y) = Just y
f _ _ = Nothing
dataDir :: Lens Atoms (Maybe FilePath)
dataDir = lens g s
where
g atoms =
fmap (\ p -> let PackageName pkgname = pkgName . package $ p in
"usr/share" </> map toLower pkgname) (getL packageDescription atoms)
s _ _ = error "setL dataDir"
compiler :: Lens Atoms (Maybe Compiler)
compiler = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DHCompiler x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')
from Source (DHCompiler x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHCompiler) x)) atoms
where
f Source (DHCompiler y) = Just y
f _ _ = Nothing
extraLibMap :: Lens Atoms (Map String (Set Relations))
extraLibMap = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from Source (ExtraLibMapping cabal debian) x = Map.insertWith union cabal (singleton debian) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ cabal debian atoms' -> Set.fold (\ debian' atoms'' -> insertAtom Source (ExtraLibMapping cabal debian') atoms'') atoms' debian) (deleteAtoms p atoms) x
where
p Source (ExtraLibMapping _ _) = True
p _ _ = False
execMap :: Lens Atoms (Map String Relations)
execMap = lens g s
where
g :: Atoms -> Map String Relations
g atoms = foldAtoms from Map.empty atoms
where
from :: DebAtomKey -> DebAtom -> Map String Relations -> Map String Relations
from Source (ExecMapping cabal debian) x = Map.insertWith (error "Conflict in execMap") cabal debian x
from _ _ x = x
s :: Map String Relations -> Atoms -> Atoms
s x atoms = Map.foldWithKey (\ cabal debian atoms' -> insertAtom Source (ExecMapping cabal debian) atoms') (deleteAtoms p atoms) x
where
p Source (ExecMapping _ _) = True
p _ _ = False
cabalFlagAssignments :: Lens Atoms (Set (FlagName, Bool))
cabalFlagAssignments = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (DHCabalFlagAssignments pairs) x = union pairs x
from _ _ x = x
s x atoms = insertAtom Source (DHCabalFlagAssignments x) (deleteAtoms p atoms)
where
p Source (DHCabalFlagAssignments _) = True
p _ _ = False
debianNameMap :: Lens Atoms (Map PackageName VersionSplits)
debianNameMap = lens g s
where
g atoms = foldAtoms from mempty atoms
where
from Source (DebianNameMap mp) _ = mp
from _ _ mp = mp
s x atoms = insertAtom Source (DebianNameMap x) (deleteAtoms p atoms)
where
p Source (DebianNameMap _) = True
p _ _ = False
epochMap :: Lens Atoms (Map PackageName Int)
epochMap = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from Source (EpochMapping name epoch) x = Map.insertWith (error "Conflicting Epochs") name epoch x
from _ _ x = x
s x atoms = Map.foldWithKey (\ name epoch atoms' -> insertAtom Source (EpochMapping name epoch) atoms') (deleteAtoms p atoms) x
where
p Source (EpochMapping _ _) = True
p _ _ = False
description :: Lens Atoms (Map BinPkgName Text)
description = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHDescription d) x = Map.insertWith (error "description") b d x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHDescription y) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHDescription _) = True
p _ _ = False
executable :: Lens Atoms (Map BinPkgName InstallFile)
executable = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHExecutable f) x = Map.insertWith (\ k a -> error $ "executable: " ++ show (k, a)) b f x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHExecutable y) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHExecutable _) = True
p _ _ = False
serverInfo :: Lens Atoms (Map BinPkgName Server)
serverInfo = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHServer s') x = Map.insertWith (error "server") b s' x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHServer y) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHServer _) = True
p _ _ = False
website :: Lens Atoms (Map BinPkgName Site)
website = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHWebsite s') x = Map.insertWith (error "website") b s' x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHWebsite y) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHWebsite _) = True
p _ _ = False
backups :: Lens Atoms (Map BinPkgName String)
backups = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHBackups s') x = Map.insertWith (error "backups") b s' x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHBackups y) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHBackups _) = True
p _ _ = False
apacheSite :: Lens Atoms (Map BinPkgName (String, FilePath, Text))
apacheSite = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHApacheSite dom log text) x = Map.insertWith (error "backups") b (dom, log, text) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b (dom, log, text) atoms' -> insertAtom (Binary b) (DHApacheSite dom log text) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHApacheSite _ _ _) = True
p _ _ = False
missingDependencies :: Lens Atoms (Set BinPkgName)
missingDependencies = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (MissingDependency b) x = Set.insert b x
from _ _ x = x
s x atoms = Set.fold (\ b atoms' -> insertAtom Source (MissingDependency b) atoms') (deleteAtoms p atoms) x
where
p Source (MissingDependency _) = True
p _ _ = False
utilsPackageName :: Lens Atoms (Maybe BinPkgName)
utilsPackageName = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (UtilsPackageName x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')
from Source (UtilsPackageName x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . UtilsPackageName) x)) atoms
where
f Source (UtilsPackageName y) = Just y
f _ _ = Nothing
sourcePackageName :: Lens Atoms (Maybe SrcPkgName)
sourcePackageName = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (SourcePackageName x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')
from Source (SourcePackageName x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . SourcePackageName) x)) atoms
where
f Source (SourcePackageName y) = Just y
f _ _ = Nothing
revision :: Lens Atoms (Maybe String)
revision = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebRevision x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DebRevision x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRevision) x)) atoms
where
f Source (DebRevision y) = Just y
f _ _ = Nothing
debVersion :: Lens Atoms (Maybe DebianVersion)
debVersion = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebVersion x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DebVersion x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebVersion) x)) atoms
where
f Source (DebVersion y) = Just y
f _ _ = Nothing
maintainer :: Lens Atoms (Maybe NameAddr)
maintainer = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DHMaintainer x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DHMaintainer x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHMaintainer) x)) atoms
where
f Source (DHMaintainer y) = Just y
f _ _ = Nothing
packageInfo :: Lens Atoms (Map PackageName PackageInfo)
packageInfo = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from Source (DebPackageInfo i) x = Map.insert (cabalName i) i x
from _ _ x = x
s x atoms =
Map.fold (\ i atoms' -> insertAtom Source (DebPackageInfo i) atoms') (deleteAtoms p atoms) x
where
p Source (DebPackageInfo _) = True
p _ _ = False
omitLTDeps :: Lens Atoms Bool
omitLTDeps = lens g s
where
g atoms = foldAtoms from False atoms
where
from Source OmitLTDeps _ = True
from _ _ x = x
s x atoms = (if x then insertAtom Source OmitLTDeps else id) (deleteAtoms p atoms)
where
p Source OmitLTDeps = True
p _ _ = False
noProfilingLibrary :: Lens Atoms Bool
noProfilingLibrary = lens g s
where
g atoms = foldAtoms from False atoms
where
from Source NoProfilingLibrary _ = True
from _ _ x = x
s x atoms = (if x then insertAtom Source NoProfilingLibrary else id) (deleteAtoms p atoms)
where
p Source NoProfilingLibrary = True
p _ _ = False
noDocumentationLibrary :: Lens Atoms Bool
noDocumentationLibrary = lens g s
where
g atoms = foldAtoms from False atoms
where
from Source NoDocumentationLibrary _ = True
from _ _ x = x
s x atoms = (if x then insertAtom Source NoDocumentationLibrary else id) (deleteAtoms p atoms)
where
p Source NoDocumentationLibrary = True
p _ _ = False
copyright :: Lens Atoms (Maybe (Either License Text))
copyright = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebCopyright x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DebCopyright x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCopyright) x)) atoms
where
f Source (DebCopyright y) = Just y
f _ _ = Nothing
sourceArchitecture :: Lens Atoms (Maybe PackageArchitectures)
sourceArchitecture = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DHArch x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DHArch x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHArch) x)) atoms
where
f Source (DHArch y) = Just y
f _ _ = Nothing
binaryArchitectures :: Lens Atoms (Map BinPkgName PackageArchitectures)
binaryArchitectures = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHArch x) m = Map.insert b x m
from _ _ m = m
s x atoms = Map.foldWithKey (\ b a atoms' -> insertAtom (Binary b) (DHArch a) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHArch _) = True
p _ _ = False
sourcePriority :: Lens Atoms (Maybe PackagePriority)
sourcePriority = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DHPriority x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DHPriority x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPriority) x)) atoms
where
f Source (DHPriority y) = Just y
f _ _ = Nothing
binaryPriorities :: Lens Atoms (Map BinPkgName PackagePriority)
binaryPriorities = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHPriority p) x = Map.insertWith (error "priorities") b p x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b p' atoms'-> insertAtom (Binary b) (DHPriority p') atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHPriority _) = True
p _ _ = False
sourceSection :: Lens Atoms (Maybe Section)
sourceSection = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DHSection x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DHSection x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHSection) x)) atoms
where
f Source (DHSection y) = Just y
f _ _ = Nothing
binarySections :: Lens Atoms (Map BinPkgName Section)
binarySections = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHSection p) x = Map.insertWith (error "sections") b p x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b p' atoms'-> insertAtom (Binary b) (DHSection p') atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHSection _) = True
p _ _ = False
buildDeps :: Lens Atoms (Set Relations)
buildDeps = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (BuildDep r) x = Set.insert r x
from _ _ x = x
s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDep d) atoms') (deleteAtoms p atoms) x
where
p Source (BuildDep _) = True
p _ _ = False
buildDepsIndep :: Lens Atoms (Set Relations)
buildDepsIndep = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (BuildDepIndep r) x = Set.insert r x
from _ _ x = x
s r atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDepIndep d) atoms') (deleteAtoms p atoms) r
where
p Source (BuildDepIndep _) = True
p _ _ = False
depends :: Lens Atoms (Map BinPkgName (Set Relation))
depends = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (Depends rel) x = Map.insertWith union b (singleton rel) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Depends rel) atoms'') atoms' rels) (deleteAtoms p atoms) x
where
p (Binary _) (Depends _) = True
p _ _ = False
conflicts :: Lens Atoms (Map BinPkgName (Set Relation))
conflicts = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (Conflicts rel) x = Map.insertWith union b (singleton rel) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Conflicts rel) atoms'') atoms' rels) (deleteAtoms p atoms) x
where
p (Binary _) (Conflicts _) = True
p _ _ = False
replaces :: Lens Atoms (Map BinPkgName (Set Relation))
replaces = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (Replaces rel) x = Map.insertWith union b (singleton rel) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Replaces rel) atoms'') atoms' rels) (deleteAtoms p atoms) x
where
p (Binary _) (Replaces _) = True
p _ _ = False
provides :: Lens Atoms (Map BinPkgName (Set Relation))
provides = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (Provides rel) x = Map.insertWith union b (singleton rel) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Provides rel) atoms'') atoms' rels) (deleteAtoms p atoms) x
where
p (Binary _) (Provides _) = True
p _ _ = False
extraDevDeps :: Lens Atoms (Set Relation)
extraDevDeps = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (DevDepends b) x = Set.insert b x
from _ _ x = x
s x atoms = Set.fold (\ d atoms' -> insertAtom Source (DevDepends d) atoms') (deleteAtoms p atoms) x
where
p Source (DevDepends _) = True
p _ _ = False
rulesHead :: Lens Atoms (Maybe Text)
rulesHead = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebRulesHead x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x')
from Source (DebRulesHead x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRulesHead) x)) atoms
where
f Source (DebRulesHead y) = Just y
f _ _ = Nothing
rulesFragments :: Lens Atoms (Set Text)
rulesFragments = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (DebRulesFragment t) x = Set.insert t x
from _ _ x = x
s x atoms = Set.fold (\ text atoms' -> insertAtom Source (DebRulesFragment text) atoms') (deleteAtoms p atoms) x
where
p Source (DebRulesFragment _) = True
p _ _ = False
postInst :: Lens Atoms (Map BinPkgName Text)
postInst = lens g s
where
g atoms = foldAtoms from mempty atoms
where
from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text
from (Binary b) (DHPostInst t) x = Map.insertWith (error "Conflicting postInsts") b t x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostInst t) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHPostInst _) = True
p _ _ = False
postRm :: Lens Atoms (Map BinPkgName Text)
postRm = lens g s
where
g atoms = foldAtoms from mempty atoms
where
from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text
from (Binary b) (DHPostRm t) m = Map.insertWith (error "Conflicting postRms") b t m
from _ _ x = x
s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostRm t) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHPostRm _) = True
p _ _ = False
preInst :: Lens Atoms (Map BinPkgName Text)
preInst = lens g s
where
g atoms = foldAtoms from mempty atoms
where
from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text
from (Binary b) (DHPreInst t) m = Map.insertWith (error "Conflicting preInsts") b t m
from _ _ x = x
s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreInst t) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHPreInst _) = True
p _ _ = False
preRm :: Lens Atoms (Map BinPkgName Text)
preRm = lens g s
where
g atoms = foldAtoms from mempty atoms
where
from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text
from (Binary b) (DHPreRm t) m = Map.insertWith (error "Conflicting preRms") b t m
from _ _ x = x
s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreRm t) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHPreRm _) = True
p _ _ = False
compat :: Lens Atoms (Maybe Int)
compat = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebCompat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')
from Source (DebCompat x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCompat) x)) atoms
where
f Source (DebCompat y) = Just y
f _ _ = Nothing
sourceFormat :: Lens Atoms (Maybe SourceFormat)
sourceFormat = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebSourceFormat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')
from Source (DebSourceFormat x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebSourceFormat) x)) atoms
where
f Source (DebSourceFormat y) = Just y
f _ _ = Nothing
watch :: Lens Atoms (Maybe Text)
watch = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebWatch x') (Just x) | x /= x' = error $ "Conflicting watch values:" ++ show (x, x')
from Source (DebWatch x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebWatch) x)) atoms
where
f Source (DebWatch y) = Just y
f _ _ = Nothing
changelog :: Lens Atoms (Maybe ChangeLog)
changelog = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebChangeLog x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x')
from Source (DebChangeLog x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebChangeLog) x)) atoms
where
f Source (DebChangeLog y) = Just y
f _ _ = Nothing
comments :: Lens Atoms (Maybe [[Text]])
comments = lens g s
where
g atoms = foldAtoms from Nothing atoms
where
from Source (DebLogComments xss') (Just xss) | xss == xss' = error $ "Conflicting log comments: " ++ show (xss, xss')
from Source (DebLogComments xss) _ = Just xss
from _ _ x = x
s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebLogComments) x)) atoms
where
f Source (DebLogComments y) = Just y
f _ _ = Nothing
control :: Lens Atoms SourceDebDescription
control = lens g s
where
g atoms = fromMaybe newSourceDebDescription $ foldAtoms from Nothing atoms
where
from Source (DebControl x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x')
from Source (DebControl x) _ = Just x
from _ _ x = x
s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DebControl) x)) atoms
where
f Source (DebControl y) = Just y
f _ _ = Nothing
standards :: Lens Atoms (Maybe StandardsVersion)
standards = lens (\ a -> standardsVersion (getL control a)) (\ b a -> modL control (\ x -> x {standardsVersion = b}) a)
logrotateStanza :: Lens Atoms (Map BinPkgName (Set Text))
logrotateStanza = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHLogrotateStanza r) x = Map.insertWith Set.union b (singleton r) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b ts atoms'-> Set.fold (\ t atoms'' -> insertAtom (Binary b) (DHLogrotateStanza t) atoms'') atoms' ts) (deleteAtoms p atoms) x
where
p (Binary _) (DHLogrotateStanza _) = True
p _ _ = False
link :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))
link = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHLink loc txt) x = Map.insertWith Set.union b (singleton (loc, txt)) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (loc, txt) atoms'' -> insertAtom (Binary b) (DHLink loc txt) atoms'') atoms' pairs) (deleteAtoms p atoms) x
where
p (Binary _) (DHLink _ _) = True
p _ _ = False
install :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))
install = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHInstall src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstall src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x
where
p (Binary _) (DHInstall _ _) = True
p _ _ = False
installTo :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))
installTo = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHInstallTo src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallTo src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x
where
p (Binary _) (DHInstallTo _ _) = True
p _ _ = False
installData :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath)))
installData = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHInstallData src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallData src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x
where
p (Binary _) (DHInstallData _ _) = True
p _ _ = False
file :: Lens Atoms (Map BinPkgName (Set (FilePath, Text)))
file = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHFile path text) x = Map.insertWith Set.union b (singleton (path, text)) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (path, text) atoms'' -> insertAtom (Binary b) (DHFile path text) atoms'') atoms' pairs) (deleteAtoms p atoms) x
where
p (Binary _) (DHFile _ _) = True
p _ _ = False
installCabalExec :: Lens Atoms (Map BinPkgName (Set (String, FilePath)))
installCabalExec = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHInstallCabalExec name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExec name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x
where
p (Binary _) (DHInstallCabalExec _ _) = True
p _ _ = False
installCabalExecTo :: Lens Atoms (Map BinPkgName (Set (String, FilePath)))
installCabalExecTo = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHInstallCabalExecTo name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExecTo name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x
where
p (Binary _) (DHInstallCabalExecTo _ _) = True
p _ _ = False
installDir :: Lens Atoms (Map BinPkgName (Set FilePath))
installDir = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHInstallDir path) x = Map.insertWith Set.union b (singleton path) x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b paths atoms'-> Set.fold (\ path atoms'' -> insertAtom (Binary b) (DHInstallDir path) atoms'') atoms' paths) (deleteAtoms p atoms) x
where
p (Binary _) (DHInstallDir _) = True
p _ _ = False
installInit :: Lens Atoms (Map BinPkgName Text)
installInit = lens g s
where
g atoms = foldAtoms from Map.empty atoms
where
from (Binary b) (DHInstallInit text) x = Map.insertWith (error "installInit") b text x
from _ _ x = x
s x atoms = Map.foldWithKey (\ b text atoms'-> insertAtom (Binary b) (DHInstallInit text) atoms') (deleteAtoms p atoms) x
where
p (Binary _) (DHInstallInit _) = True
p _ _ = False
intermediateFiles :: Lens Atoms (Set (FilePath, Text))
intermediateFiles = lens g s
where
g atoms = foldAtoms from Set.empty atoms
where
from Source (DHIntermediate path text) x = Set.insert (path, text) x
from _ _ x = x
s x atoms = Set.fold (\ (path, text) atoms' -> insertAtom Source (DHIntermediate path text) atoms') (deleteAtoms p atoms) x
where
p Source (DHIntermediate _ _) = True
p _ _ = False
defaultFlags :: Flags
defaultFlags =
Flags {
verbosity_ = 1
, debAction_ = Usage
, dryRun_ = False
, validate_ = False
}
insertAtom :: DebAtomKey -> DebAtom -> Atoms -> Atoms
insertAtom mbin atom (Atoms x) = Atoms (insertWith union mbin (singleton atom) x)
insertAtoms :: Set (DebAtomKey, DebAtom) -> Atoms -> Atoms
insertAtoms s atoms =
case maxView s of
Nothing -> atoms
Just ((k, a), s') -> insertAtoms s' (insertAtom k a atoms)
foldAtoms :: (DebAtomKey -> DebAtom -> r -> r) -> r -> Atoms -> r
foldAtoms f r0 (Atoms xs) = Map.foldWithKey (\ k s r -> Set.fold (f k) r s) r0 xs
partitionAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> (Set (DebAtomKey, DebAtom), Atoms)
partitionAtoms f deb =
foldAtoms g (mempty, Atoms mempty) deb
where
g k atom (atoms, deb') =
case f k atom of
True -> (Set.insert (k, atom) atoms, deb')
False -> (atoms, insertAtom k atom deb')
deleteAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> Atoms
deleteAtoms p atoms = snd (partitionAtoms p atoms)
partitionAtoms' :: (Ord a) => (DebAtomKey -> DebAtom -> Maybe a) -> Atoms -> (Set a, Atoms)
partitionAtoms' f deb =
foldAtoms g (mempty, Atoms mempty) deb
where
g k atom (xs, deb') =
case f k atom of
Just x -> (Set.insert x xs, deb')
Nothing -> (xs, insertAtom k atom deb')
modifyAtoms' :: (Ord a) =>
(DebAtomKey -> DebAtom -> Maybe a)
-> (Set a -> Set (DebAtomKey, DebAtom))
-> Atoms
-> Atoms
modifyAtoms' f g atoms =
insertAtoms (g s) atoms'
where
(s, atoms') = partitionAtoms' f atoms