import Distribution.PackageDescription
(PackageDescription,SourceRepo,RepoKind(RepoHead),RepoType(..),repoLocation,repoKind,
repoType,package,homepage,synopsis,buildDepends,maintainer,licenseFile,
license,library,description,sourceRepos)
import Distribution.PackageDescription.Configuration
(flattenPackageDescription)
import Distribution.PackageDescription.Parse
(readPackageDescription)
import Distribution.Simple
import Distribution.Simple.Utils
(defaultPackageDesc)
import Distribution.Verbosity
(normal)
import Distribution.License
(License)
import Text.XML.HXT.Arrow
import Data.Maybe (catMaybes,listToMaybe)
import Data.Either (rights)
import Data.List (nub)
import Data.Version (showVersion)
import Text.ParserCombinators.Parsec (parse)
import Text.ParserCombinators.Parsec.Rfc2822
(mailbox_list,mailbox,NameAddr,nameAddr_addr,nameAddr_name)
import System.Process (readProcessWithExitCode)
import System.Exit (ExitCode(..))
-- Common namespaces
doap_ns = "http://usefulinc.com/ns/doap#"
foaf_ns = "http://xmlns.com/foaf/0.1/"
rdf_ns = "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
------ Qualified Names we'll make use of
-- RDF QNames
rdfQ = mkQName "rdf" "RDF" rdf_ns
rdfresQ = mkQName "rdf" "resource" rdf_ns
rdfaboutQ = mkQName "rdf" "about" rdf_ns
-- DOAP QNames
projectQ = mkQName "doap" "Project" doap_ns
proj_nameQ = mkQName "doap" "name" doap_ns
shortdescQ = mkQName "doap" "shortdesc" doap_ns
descQ = mkQName "doap" "description" doap_ns
homepageQ = mkQName "doap" "homepage" doap_ns
licenseQ = mkQName "doap" "license" doap_ns
releaseQ = mkQName "doap" "release" doap_ns
versionQ = mkQName "doap" "Version" doap_ns
revisionQ = mkQName "doap" "revision" doap_ns
maintainerQ = mkQName "doap" "maintainer" doap_ns
developerQ = mkQName "doap" "developer" doap_ns
programminglangQ = mkQName "doap" "programming-language" doap_ns
repoRelQ = mkQName "doap" "repository" doap_ns
repoQ = mkQName "doap" "Repository" doap_ns
locationQ = mkQName "doap" "location" doap_ns
-- FOAF QNames
personQ = mkQName "foaf" "Person" foaf_ns
nameQ = mkQName "foaf" "name" foaf_ns
mboxQ = mkQName "foaf" "mbox" foaf_ns
-- directly map a string field to a DOAP top-level project element.
-- Empty strings result in Nothing.
simpleElement :: ArrowXml a => String -> QName -> Maybe (a XmlTree XmlTree)
simpleElement n qn = case n of
[] -> Nothing
_ -> Just (mkqelem qn [] [txt n])
-- Create homepage DOAP element, if it exists.
homepageElement :: ArrowXml a => String -> Maybe (a XmlTree XmlTree)
homepageElement h = case h of
[] -> Nothing
_ -> Just (mkqelem homepageQ [sqattr rdfresQ h] [])
-- Create release/version elements, if a Cabal version was specified.
-- release, Version, name/created/revision
versionElement :: ArrowXml a => String -> Maybe (a XmlTree XmlTree)
versionElement v =
case v of
[] -> Nothing
_ -> Just $ mkqelem releaseQ []
[mkqelem versionQ [] [mkqelem revisionQ [] [txt v]]]
-- Create maintainer elements, one for each address listed.
maintainerElements :: ArrowXml a => String -> [a XmlTree XmlTree]
maintainerElements m =
let mboxes_parsed = parse mailbox_list "maintainers" m in
case mboxes_parsed of
Left _ -> [] --Error
Right mboxes -> map (personElementFromAddr maintainerQ) mboxes
personElementFromAddr :: ArrowXml a => QName -> NameAddr -> a XmlTree XmlTree
personElementFromAddr rel na =
mkqelem rel []
[mkqelem personQ []
(mkqelem mboxQ
[sqattr rdfresQ ("mailto:" ++ nameAddr_addr na)] []
: nameElems)]
where
nameElems = case (nameAddr_name na) of
Nothing -> []
Just name -> [mkqelem nameQ [] [txt name]]
-- Need URIs for other Cabal-recognized licenses
licenseElement :: ArrowXml a => License -> Maybe (a XmlTree XmlTree)
licenseElement l =
case l of
GPL -> Just (mkqelem licenseQ
[sqattr rdfresQ "http://usefulinc.com/doap/licenses/gpl"] [])
LGPL -> Just (mkqelem licenseQ
[sqattr rdfresQ "http://usefulinc.com/doap/licenses/lgpl"] [])
BSD3 -> Just (mkqelem licenseQ
[sqattr rdfresQ "http://usefulinc.com/doap/licenses/bsd"] [])
BSD4 -> Nothing
PublicDomain -> Nothing
AllRightsReserved -> Nothing
OtherLicense -> Nothing
UnknownLicense n -> Nothing
-- Find a "HEAD" source repository, if one exists, and reference the location.
-- Note: An active ticket on the DOAP Trac has a proposal for Darcs as
-- a subclass of Repository. We should use that as soon as it becomes
-- official.
sourceRepoElement :: ArrowXml a => [SourceRepo] -> Maybe (a XmlTree XmlTree)
sourceRepoElement repos =
fmap (\r -> mkqelem repoRelQ [] [
mkqelem repoQ [] [
mkqelem locationQ [sqattr rdfresQ r] []
]]) source_repo
where
head_repos = filter (\r -> repoKind r == RepoHead) repos
source_repo = listToMaybe head_repos >>= repoLocation
developerElements :: ArrowXml a => [NameAddr] -> [a XmlTree XmlTree]
developerElements = map (personElementFromAddr developerQ)
doapFromPackageDesc :: ArrowXml a => PackageDescription -- ^ Cabal package
-> [NameAddr] -- ^ Developer addresses
-> a XmlTree XmlTree
doapFromPackageDesc pkg_desc developers =
mkqelem rdfQ [] [
mkqelem projectQ [sqattr rdfaboutQ (homepage pkg_desc)]
(catMaybes
[(simpleElement (nameFromPkgDesc pkg_desc) proj_nameQ),
(simpleElement (synopsis pkg_desc) shortdescQ),
(simpleElement (description pkg_desc) descQ),
(simpleElement "Haskell" programminglangQ),
(licenseElement (license pkg_desc)),
(homepageElement (homepage pkg_desc)),
(sourceRepoElement (sourceRepos pkg_desc)),
(versionElement (showVersion (packageVersion (package pkg_desc))))
] ++ maintainerElements (maintainer pkg_desc)
++ developerElements developers
)
]
nameFromPkgDesc :: PackageDescription -> String
nameFromPkgDesc pkg_desc = case (pkgName (package pkg_desc)) of
PackageName n -> n
-- Use darcs repo to get a change log (XML)
getDarcsChanges :: IO (Maybe String)
getDarcsChanges =
do (ec, out, err) <- readProcessWithExitCode "darcs" ["changes", "--xml-output"] ""
case ec of
ExitSuccess -> return (Just out)
ExitFailure _ -> return Nothing
-- The vast majority of darcs author fields look like either:
-- contrib@example.org OR
-- Contributor Name <contrib@example.org>
developersFromDarcs :: String -- ^ Darcs XML changes
-> IO [NameAddr] -- ^ list of developers
developersFromDarcs xml =
do res <- runX (readString [] xml >>>
deep (isElem >>>
hasName "patch") >>>
getAttrValue "author")
let uniq_dvlp = map (parse mailbox "developers") (nub res)
return (rights uniq_dvlp)
main = do
chg <- getDarcsChanges
dvlprs <- maybe (return []) developersFromDarcs chg
packageDescPath <- defaultPackageDesc normal
gDesc <- readPackageDescription normal packageDescPath
let desc = flattenPackageDescription gDesc
runX (root [] [doapFromPackageDesc desc dvlprs
>>> uniqueNamespacesFromDeclAndQNames
]
>>> writeDocument [(a_indent,v_1),(a_check_namespaces, v_1)] "-")
return ()