Remove code duplication
[darcs-mirror-hpvt.git] / PlatformOutput.hs
1 {-# LANGUAGE PatternGuards #-}
2 module PlatformOutput (outputPlatform) where
3
4 import Text.XHtml hiding (version)
5 import qualified Data.Map as M
6 import qualified Data.Set as S
7 import Data.Maybe
8 import Data.Char
9 import System.Time
10
11 import Distribution.Package hiding (PackageName)
12 import Distribution.PackageDescription
13 import Distribution.Text
14 import Distribution.Version (VersionRange(ThisVersion))
15 import qualified Data.Version as DV
16 import Data.Version (showVersion, parseVersion)
17 import Text.ParserCombinators.ReadP (readP_to_S, between, eof)
18
19 import Types
20 import Utils
21
22 outputPlatform :: (Show t) => t -> 
23  DistroInfo ->
24  [ (PackageDescription,[(String, M.Map PackageName Version)]) ] ->
25  String
26 outputPlatform time hackage datas = showHtml $ page time << mkTable hackage datas
27
28 myTitle = "Haskell Platform Version Tracker"
29
30 page time content = thehtml << (header << thetitle << myTitle +++
31                            body << (
32                                 h1 << myTitle +++
33                                 p << ("Last update: " +++ show time) +++
34                                 content +++
35                                 footer))
36
37 mkTable hackage datas = table << (
38                 tr << (
39                     th << "Package name" +++
40                     concatHtml (map (\(p,dists) ->
41                         th << (display (pkgName (package p)) +++ br +++
42                                display (pkgVersion (package p))) +++
43                         concatHtml (map (\(name,_) ->
44                             th << name
45                         ) dists) +++
46                         th << (spaceHtml +++ spaceHtml +++ spaceHtml +++ spaceHtml +++ spaceHtml)
47                     ) datas) +++
48                     th << "Hackage"
49                 ) +++
50                 (concatHtml $ map row $ S.toList pkgs)
51                 )
52   where buildDependsMap pd = M.fromList (map fromDep deps)
53           where fromDep (Dependency pkg (ThisVersion ver)) = (fromCabal pkg,ver)
54                 fromDep d = error $ "Unexpected dependency format " ++ display d
55                 deps = buildDepends pd ++ buildTools bi
56                 bi = libBuildInfo (fromJust (library pd))
57         maps = map (\(p,dists) -> (buildDependsMap p,dists)) datas
58         pkgs = S.unions (map (M.keysSet . fst) maps)
59         
60
61         row pkg = tr << (
62                       td << show pkg +++
63                       concatHtml (map (\(pm,dists) ->
64                         case M.lookup pkg pm of
65                             Just ver -> 
66                                 td << showVersion ver +++
67                                 concatHtml (map (\(_,dm) -> case M.lookup pkg dm of
68                                     Just dver ->
69                                         mkCell dver $
70                                             " " +++ vCmp ver dver
71                                     Nothing -> none
72                                 ) dists) +++
73                                 emptyCell
74                             Nothing ->
75                                 emptyCell +++
76                                 concatHtml (map (const emptyCell) dists) +++
77                                 emptyCell
78                       ) maps) +++
79                       case M.lookup pkg hackage of
80                         Just hver -> mkCell hver noHtml
81                         Nothing -> none
82                   )
83         mkCell (Version v u) more = td << (hotlink u << v +++ more)
84         none = td << "–"
85         emptyCell = td << noHtml
86
87         vCmp ver (Version dver _) = case dver' `compare` ver of
88             LT -> "(<)"
89             EQ -> "(=)"
90             GT -> "(>)"
91             where dver' | Just ver' <- fromDotless (upstream dver)
92                             = ver'
93                         | otherwise
94                             = parseVersion' (upstream dver)
95
96 fromDotless str =
97     if length str == 8 && all isDigit str
98     then Just (DV.Version (map read [take 4 str, take 2 (drop 4 str), drop 6 str]) [])
99     else Nothing
100         
101
102 parseVersion' str =
103     case readP_to_S (between (return ()) eof parseVersion) str of
104         [(v,"")] -> v
105         x -> error $ "Could not parse " ++ str ++ ": " ++ show x
106
107
108 footer = p << ("This is created by " +++
109                hotlink "http://darcs.nomeata.de/hpvt/" << "hptv" +++
110                ", written by " +++
111                hotlink "mailto:mail@joachim-breitner.de" << "Joachim Breitner" +++
112                ". At the moment it is updated automatically every night.")