{-# 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 :: [Char] -> Either ParseError Relations
parseRelations [Char]
str =
        let str' :: [Char]
str' = [Char] -> [Char]
scrub [Char]
str in
        case Parsec [Char] () Relations
-> [Char] -> [Char] -> Either ParseError Relations
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec [Char] () Relations
pRelations [Char]
str' [Char]
str' of
          Right Relations
relations -> Relations -> Either ParseError Relations
forall a b. b -> Either a b
Right ((OrRelation -> Bool) -> Relations -> Relations
forall a. (a -> Bool) -> [a] -> [a]
filter (OrRelation -> OrRelation -> Bool
forall a. Eq a => a -> a -> Bool
/= []) Relations
relations)
          Either ParseError Relations
x -> Either ParseError Relations
x
        where
          scrub :: [Char] -> [Char]
scrub = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
comment) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
          comment :: [Char] -> Bool
comment [Char]
s = case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ', Char
'\t']) [Char]
s of
                           (Char
'#' : [Char]
_) -> Bool
True
                           [Char]
_ -> 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 [Char] () Relations
pRelations = do -- rel <- sepBy pOrRelation (char ',')
                rel <- ParsecT [Char] () Identity OrRelation -> Parsec [Char] () Relations
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT [Char] () Identity OrRelation
pOrRelation
                eof
                return rel

pOrRelation :: RelParser OrRelation
pOrRelation :: ParsecT [Char] () Identity OrRelation
pOrRelation = do ParsecT [Char] () Identity Char -> ParsecT [Char] () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] () Identity Char
forall u. ParsecT [Char] u Identity Char
whiteChar)
                 rel <- ParsecT [Char] () Identity Relation
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity OrRelation
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 [Char] () Identity Relation
pRelation (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'|')
                 skipMany (char ',' <|> whiteChar)
                 return rel

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

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

pMaybeVerReq :: RelParser (Maybe VersionReq)
pMaybeVerReq :: RelParser (Maybe VersionReq)
pMaybeVerReq =
    do Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'('
       ParsecT [Char] () Identity Char -> ParsecT [Char] () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Char] () Identity Char
forall u. ParsecT [Char] u Identity Char
whiteChar
       op <- ParsecT [Char] () Identity (DebianVersion -> VersionReq)
forall u. ParsecT [Char] u Identity (DebianVersion -> VersionReq)
pVerReq
       skipMany whiteChar
       ver <- many1 (noneOf [' ',')','\t','\n'])
       skipMany whiteChar
       char ')'
       return $ Just (op (parseDebianVersion' 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 a. a -> ParsecT [Char] () Identity a
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 :: forall u. ParsecT [Char] u Identity (DebianVersion -> VersionReq)
pVerReq =
    do Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<'
       (do Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] 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 [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] 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 [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\t'
           (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT [Char] u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
SLT
        ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] 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 [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
           (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT [Char] u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
LTE)
    ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] 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 [Char] u Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"="
       (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT [Char] u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
EEQ
    ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] 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 [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>'
       (do Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
           (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT [Char] u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a b. (a -> b) -> a -> b
$ DebianVersion -> VersionReq
GRE
        ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
-> ParsecT [Char] 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 [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] 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 [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] 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 [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\t'
           (DebianVersion -> VersionReq)
-> ParsecT [Char] u Identity (DebianVersion -> VersionReq)
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((DebianVersion -> VersionReq)
 -> ParsecT [Char] u Identity (DebianVersion -> VersionReq))
-> (DebianVersion -> VersionReq)
-> ParsecT [Char] 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 [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'['
       (do archs <- RelParser [[Char]]
pArchExcept
           char ']'
           skipMany whiteChar
           return (Just (ArchExcept (fromList . map parseArchExcept $ 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 archs <- RelParser [[Char]]
pArchOnly
           char ']'
           skipMany whiteChar
           return (Just (ArchOnly (fromList . map parseArch $ 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 a. a -> ParsecT [Char] () Identity a
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 [[Char]]
pArchExcept = ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity () -> RelParser [[Char]]
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 [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'!' ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char
']',Char
' '])) (ParsecT [Char] () Identity Char -> ParsecT [Char] () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT [Char] () Identity Char
forall u. ParsecT [Char] u Identity Char
whiteChar)

pArchOnly :: RelParser [String]
pArchOnly :: RelParser [[Char]]
pArchOnly = ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity () -> RelParser [[Char]]
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 [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char
']',Char
' '])) (ParsecT [Char] () Identity Char -> ParsecT [Char] () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT [Char] () Identity Char
forall u. ParsecT [Char] 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 :: [Char] -> Arch
parseArchExcept (Char
'!' : [Char]
s) = [Char] -> Arch
parseArch [Char]
s
parseArchExcept [Char]
s = [Char] -> Arch
parseArch [Char]
s