{-# LANGUAGE FlexibleInstances, PackageImports, TypeSynonymInstances #-}
{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-orphans #-}
-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>
module Debian.Relation.String
    ( -- * Types
      AndRelation
    , OrRelation
    , Relations
    , Relation(..)
    , ArchitectureReq(..)
    , VersionReq(..)
    -- * Helper Functions
    , checkVersionReq
    -- * Relation Parser
    , RelParser
    , ParseRelations(..)
    , pRelations
    ) where

-- Standard GHC Modules

import "mtl" Control.Monad.Identity (Identity)
import Data.Set (fromList)
import Text.ParserCombinators.Parsec
import Text.Parsec.Prim (ParsecT)

-- Local Modules

import Debian.Arch (Arch, parseArch)
import Debian.Relation.Common
import Debian.Version

-- * ParseRelations

instance ParseRelations String where
    parseRelations :: String -> Either ParseError Relations
parseRelations String
str =
        let str' :: String
str' = String -> String
scrub String
str in
        case Parsec String () Relations
-> String -> String -> Either ParseError Relations
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () Relations
pRelations String
str' String
str' of
          Right Relations
relations -> Relations -> Either ParseError Relations
forall a b. b -> Either a b
Right (([Relation] -> Bool) -> Relations -> Relations
forall a. (a -> Bool) -> [a] -> [a]
filter ([Relation] -> [Relation] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) Relations
relations)
          Either ParseError Relations
x -> Either ParseError Relations
x
        where
          scrub :: String -> String
scrub = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
comment) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
          comment :: String -> Bool
comment String
s = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ', Char
'\t']) String
s of
                           (Char
'#' : String
_) -> Bool
True
                           String
_ -> Bool
False

-- * Relation Parser

type RelParser a = CharParser () a

-- "Correct" dependency lists are separated by commas, but sometimes they
-- are omitted and it is possible to parse relations without them.
pRelations :: RelParser Relations
pRelations :: Parsec String () Relations
pRelations = do -- rel <- sepBy pOrRelation (char ',')
                Relations
rel <- ParsecT String () Identity [Relation] -> Parsec String () Relations
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity [Relation]
pOrRelation
                ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
                Relations -> Parsec String () Relations
forall (m :: * -> *) a. Monad m => a -> m a
return Relations
rel

pOrRelation :: RelParser OrRelation
pOrRelation :: ParsecT String () Identity [Relation]
pOrRelation = do ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar)
                 [Relation]
rel <- ParsecT String () Identity Relation
-> ParsecT String () Identity Char
-> ParsecT String () Identity [Relation]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1 ParsecT String () Identity Relation
pRelation (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'|')
                 ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar)
                 [Relation] -> ParsecT String () Identity [Relation]
forall (m :: * -> *) a. Monad m => a -> m a
return [Relation]
rel

whiteChar :: ParsecT String u Identity Char
whiteChar :: ParsecT String u Identity Char
whiteChar = String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf [Char
' ',Char
'\t',Char
'\n']

pRelation :: RelParser Relation
pRelation :: ParsecT String () Identity Relation
pRelation =
    do ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
       String
pkgName <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
' ',Char
',',Char
'|',Char
'\t',Char
'\n',Char
'('])
       ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
       Maybe VersionReq
mVerReq <- RelParser (Maybe VersionReq)
pMaybeVerReq
       ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
       Maybe ArchitectureReq
mArch <- RelParser (Maybe ArchitectureReq)
pMaybeArch
       Relation -> ParsecT String () Identity Relation
forall (m :: * -> *) a. Monad m => a -> m a
return (Relation -> ParsecT String () Identity Relation)
-> Relation -> ParsecT String () Identity Relation
forall a b. (a -> b) -> a -> b
$ BinPkgName -> Maybe VersionReq -> Maybe ArchitectureReq -> Relation
Rel (String -> BinPkgName
BinPkgName String
pkgName) Maybe VersionReq
mVerReq Maybe ArchitectureReq
mArch

pMaybeVerReq :: RelParser (Maybe VersionReq)
pMaybeVerReq :: RelParser (Maybe VersionReq)
pMaybeVerReq =
    do Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'('
       ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
       DebianVersion -> VersionReq
op <- ParsecT String () Identity (DebianVersion -> VersionReq)
forall u. ParsecT String u Identity (DebianVersion -> VersionReq)
pVerReq
       ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
       String
ver <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
' ',Char
')',Char
'\t',Char
'\n'])
       ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
       Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
       Maybe VersionReq -> RelParser (Maybe VersionReq)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VersionReq -> RelParser (Maybe VersionReq))
-> Maybe VersionReq -> RelParser (Maybe VersionReq)
forall a b. (a -> b) -> a -> b
$ VersionReq -> Maybe VersionReq
forall a. a -> Maybe a
Just (DebianVersion -> VersionReq
op (String -> DebianVersion
forall string. ParseDebianVersion string => string -> DebianVersion
parseDebianVersion' String
ver))
    RelParser (Maybe VersionReq)
-> RelParser (Maybe VersionReq) -> RelParser (Maybe VersionReq)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
    do Maybe VersionReq -> RelParser (Maybe VersionReq)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VersionReq -> RelParser (Maybe VersionReq))
-> Maybe VersionReq -> RelParser (Maybe VersionReq)
forall a b. (a -> b) -> a -> b
$ Maybe VersionReq
forall a. Maybe a
Nothing

pVerReq :: ParsecT [Char] u Identity (DebianVersion -> VersionReq)
pVerReq :: ParsecT String u Identity (DebianVersion -> VersionReq)
pVerReq =
    do Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<'
       (do Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\t'
           (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT String u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
SLT
        ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        do Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
           (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT String u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
LTE)
    ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
    do String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"="
       (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT String u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
EEQ
    ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
    do Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>'
       (do Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
           (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT String u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
GRE
        ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        do Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\t'
           (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT String u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT String u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
SGR)

pMaybeArch :: RelParser (Maybe ArchitectureReq)
pMaybeArch :: RelParser (Maybe ArchitectureReq)
pMaybeArch =
    do Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'['
       (do [String]
archs <- RelParser [String]
pArchExcept
           Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']'
           ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
           Maybe ArchitectureReq -> RelParser (Maybe ArchitectureReq)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchitectureReq -> Maybe ArchitectureReq
forall a. a -> Maybe a
Just (Set Arch -> ArchitectureReq
ArchExcept ([Arch] -> Set Arch
forall a. Ord a => [a] -> Set a
fromList ([Arch] -> Set Arch)
-> ([String] -> [Arch]) -> [String] -> Set Arch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Arch) -> [String] -> [Arch]
forall a b. (a -> b) -> [a] -> [b]
map String -> Arch
parseArchExcept ([String] -> Set Arch) -> [String] -> Set Arch
forall a b. (a -> b) -> a -> b
$ [String]
archs)))
        RelParser (Maybe ArchitectureReq)
-> RelParser (Maybe ArchitectureReq)
-> RelParser (Maybe ArchitectureReq)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        do [String]
archs <- RelParser [String]
pArchOnly
           Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']'
           ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar
           Maybe ArchitectureReq -> RelParser (Maybe ArchitectureReq)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchitectureReq -> Maybe ArchitectureReq
forall a. a -> Maybe a
Just (Set Arch -> ArchitectureReq
ArchOnly ([Arch] -> Set Arch
forall a. Ord a => [a] -> Set a
fromList ([Arch] -> Set Arch)
-> ([String] -> [Arch]) -> [String] -> Set Arch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Arch) -> [String] -> [Arch]
forall a b. (a -> b) -> [a] -> [b]
map String -> Arch
parseArch ([String] -> Set Arch) -> [String] -> Set Arch
forall a b. (a -> b) -> a -> b
$ [String]
archs)))
        )
    RelParser (Maybe ArchitectureReq)
-> RelParser (Maybe ArchitectureReq)
-> RelParser (Maybe ArchitectureReq)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
    Maybe ArchitectureReq -> RelParser (Maybe ArchitectureReq)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ArchitectureReq
forall a. Maybe a
Nothing

-- Some packages (e.g. coreutils) have architecture specs like [!i386
-- !hppa], even though this doesn't really make sense: once you have
-- one !, anything else you include must also be (implicitly) a !.
pArchExcept :: RelParser [String]
pArchExcept :: RelParser [String]
pArchExcept = ParsecT String () Identity String
-> ParsecT String () Identity () -> RelParser [String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'!' ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
']',Char
' '])) (ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar)

pArchOnly :: RelParser [String]
pArchOnly :: RelParser [String]
pArchOnly = ParsecT String () Identity String
-> ParsecT String () Identity () -> RelParser [String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy (ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
']',Char
' '])) (ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
whiteChar)

-- | Ignore the ! if it is present, we already know this list has at
-- least one, and the rest are implicit.
parseArchExcept :: String -> Arch
parseArchExcept :: String -> Arch
parseArchExcept (Char
'!' : String
s) = String -> Arch
parseArch String
s
parseArchExcept String
s = String -> Arch
parseArch String
s