{-|
Module      : Portage.Metadata
License     : GPL-3+
Maintainer  : haskell@gentoo.org

Functions and types related to @metadata.xml@ processing
-}
module Portage.Metadata
        ( Metadata(..)
        , metadataFromFile
        , pureMetadataFromFile
        , stripGlobalUseFlags -- exported for hspec
        , prettyPrintFlags -- exported for hspec
        , prettyPrintFlagsHuman
        , makeDefaultMetadata
        , makeMinimalMetadata
        ) where

import qualified AnsiColor as A

import qualified Data.List       as L
import qualified Data.Map.Strict as Map
import qualified Data.Text       as T
import qualified Data.Text.IO    as T

import Text.XML.Light

-- | A data type for the Gentoo-specific @metadata.xml@ file.
-- Currently defines functions for the maintainer email and
-- USE flags and their descriptions.
data Metadata = Metadata
      { Metadata -> [String]
metadataEmails :: [String] -- ^ This should /always/ be [\"haskell@gentoo.org\"].
      , Metadata -> Map String String
metadataUseFlags :: Map.Map String String -- ^ Only /active/ USE flags, if any.
      } deriving (Metadata -> Metadata -> Bool
(Metadata -> Metadata -> Bool)
-> (Metadata -> Metadata -> Bool) -> Eq Metadata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metadata -> Metadata -> Bool
$c/= :: Metadata -> Metadata -> Bool
== :: Metadata -> Metadata -> Bool
$c== :: Metadata -> Metadata -> Bool
Eq, Int -> Metadata -> ShowS
[Metadata] -> ShowS
Metadata -> String
(Int -> Metadata -> ShowS)
-> (Metadata -> String) -> ([Metadata] -> ShowS) -> Show Metadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metadata] -> ShowS
$cshowList :: [Metadata] -> ShowS
show :: Metadata -> String
$cshow :: Metadata -> String
showsPrec :: Int -> Metadata -> ShowS
$cshowsPrec :: Int -> Metadata -> ShowS
Show)

-- | Maybe return a 'Metadata' from a 'T.Text'.
--
-- Trying to parse an empty 'T.Text' should return 'Nothing':
--
-- >>> pureMetadataFromFile T.empty
-- Nothing
--
-- Parsing a @metadata.xml@ /without/ USE flags should /always/ be equivalent
-- to 'makeMinimalMetadata':
--
-- >>> pureMetadataFromFile (makeDefaultMetadata Map.empty) == Just makeMinimalMetadata
-- True
--
-- Parsing a @metadata.xml@ /with/ USE flags should /always/ be equivalent
-- to 'makeMinimalMetadata' /plus/ the supplied USE flags:
--
-- >>> pureMetadataFromFile (makeDefaultMetadata (Map.fromList [("name","description")])) == Just (makeMinimalMetadata {metadataUseFlags = Map.fromList [("name","description")] } )
-- True
pureMetadataFromFile :: T.Text -> Maybe Metadata
pureMetadataFromFile :: Text -> Maybe Metadata
pureMetadataFromFile Text
file = Text -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc Text
file Maybe Element -> (Element -> Maybe Metadata) -> Maybe Metadata
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Element
doc -> Element -> Maybe Metadata
parseMetadata Element
doc

-- | Apply 'pureMetadataFromFile' to a 'FilePath'.
metadataFromFile :: FilePath -> IO (Maybe Metadata)
metadataFromFile :: String -> IO (Maybe Metadata)
metadataFromFile String
fp = Text -> Maybe Metadata
pureMetadataFromFile (Text -> Maybe Metadata) -> IO Text -> IO (Maybe Metadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
fp

-- | Extract the maintainer email and USE flags from a supplied XML 'Element'.
-- 
-- If we're parsing a blank 'Element' or otherwise empty @metadata.xml@:
-- >>> parseMetadata blank_element
-- Just (Metadata {metadataEmails = [], metadataUseFlags = fromList []})
parseMetadata :: Element -> Maybe Metadata
parseMetadata :: Element -> Maybe Metadata
parseMetadata Element
xml =
  Metadata -> Maybe Metadata
forall (m :: * -> *) a. Monad m => a -> m a
return Metadata :: [String] -> Map String String -> Metadata
Metadata { metadataEmails :: [String]
metadataEmails = Element -> String
strContent (Element -> String) -> [Element] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> Element -> [Element]
findElements (String -> QName
unqual String
"email") Element
xml
                  , metadataUseFlags :: Map String String
metadataUseFlags =
                      -- find the flag name
                      let x :: Maybe Element
x = QName -> Element -> Maybe Element
findElement (String -> QName
unqual String
"use") Element
xml
                          y :: [Element]
y = [Content] -> [Element]
onlyElems ([Content] -> [Element]) -> [Content] -> [Element]
forall a b. (a -> b) -> a -> b
$ (Element -> [Content]) -> Maybe Element -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Element -> [Content]
elContent Maybe Element
x
                          z :: [String]
z = Attr -> String
attrVal (Attr -> String) -> [Attr] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> [Attr]) -> [Element] -> [Attr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Element -> [Attr]
elAttribs [Element]
y
                      -- find the flag description
                          a :: [Content]
a = (Element -> [Content]) -> [Element] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Element -> [Content]
elContent [Element]
y
                          b :: [String]
b = CData -> String
cdData (CData -> String) -> [CData] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Content] -> [CData]
onlyText [Content]
a
                      in [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, String)] -> Map String String)
-> [(String, String)] -> Map String String
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
z [String]
b
                  }

-- | Remove global @USE@ flags from the flags 'Map.Map', as these should not be
-- within the local @metadata.xml@. For now, this is manually specified rather than
-- parsing @use.desc@.
stripGlobalUseFlags :: Map.Map String String -> Map.Map String String
stripGlobalUseFlags :: Map String String -> Map String String
stripGlobalUseFlags Map String String
m = (Map String String -> Map String String -> Map String String)
-> [Map String String] -> Map String String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Map String String -> Map String String -> Map String String
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection (String -> Map String String -> Map String String
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (String -> Map String String -> Map String String)
-> [String] -> [Map String String -> Map String String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
globals [Map String String -> Map String String]
-> [Map String String] -> [Map String String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Map String String
m])
  where
    globals :: [String]
globals = [ String
"debug"
              , String
"examples"
              , String
"static"
              ]

-- | Pretty print as valid XML a list of flags and their descriptions
-- from a given 'Map.Map'.
prettyPrintFlags :: Map.Map String String -> [String]
prettyPrintFlags :: Map String String -> [String]
prettyPrintFlags Map String String
m = (\(String
name,String
description) ->
                        String
"\t\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        (Element -> String
showElement
                         (Element -> String) -> (String -> Element) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Element -> Element
add_attr (QName -> String -> Attr
Attr (QName
blank_name { qName :: String
qName = String
"name" }) String
name)
                         (Element -> Element) -> (String -> Element) -> String -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Element
forall t. Node t => String -> t -> Element
unode String
"flag" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
description))
                     ((String, String) -> String) -> [(String, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map String String -> [(String, String)])
-> (Map String String -> Map String String)
-> Map String String
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String String -> Map String String
stripGlobalUseFlags (Map String String -> [(String, String)])
-> Map String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ Map String String
m)

-- | Pretty print a human-readable list of flags and their descriptions
-- from a given 'Map.Map'.
prettyPrintFlagsHuman :: Map.Map String String -> [String]
prettyPrintFlagsHuman :: Map String String -> [String]
prettyPrintFlagsHuman Map String String
m = (\(String
name,String
description) -> ShowS
A.bold (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ") String -> ShowS
forall a. [a] -> [a] -> [a]
++
                            (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
" " ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
description))
                          ((String, String) -> String) -> [(String, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map String String -> [(String, String)])
-> (Map String String -> Map String String)
-> Map String String
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String String -> Map String String
stripGlobalUseFlags (Map String String -> [(String, String)])
-> Map String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ Map String String
m)
                          
-- | A minimal metadata for use as a fallback value.
makeMinimalMetadata :: Metadata
makeMinimalMetadata :: Metadata
makeMinimalMetadata = Metadata :: [String] -> Map String String -> Metadata
Metadata { metadataEmails :: [String]
metadataEmails = [String
"haskell@gentoo.org"]
                               , metadataUseFlags :: Map String String
metadataUseFlags = Map String String
forall k a. Map k a
Map.empty
                               }

-- don't use Text.XML.Light as we like our own pretty printer
-- | Pretty print the @metadata.xml@ string.
makeDefaultMetadata :: Map.Map String String -> T.Text
makeDefaultMetadata :: Map String String -> Text
makeDefaultMetadata Map String String
flags = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
  [String] -> String
unlines [ String
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
          , String
"<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"
          , String
"<pkgmetadata>"
          , String
"\t<maintainer type=\"project\">"
          , String
"\t\t<email>haskell@gentoo.org</email>"
          , String
"\t\t<name>Gentoo Haskell</name>"
          , String
"\t</maintainer>"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Map String String
flags Map String String -> Map String String -> Bool
forall a. Eq a => a -> a -> Bool
== Map String String
forall k a. Map k a
Map.empty
               then String
""
               else String
"\n\t<use>\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Map String String -> [String]
prettyPrintFlags Map String String
flags) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\t</use>"
          , String
"</pkgmetadata>"
          ]