#!/usr/bin/env runhaskell {-# OPTIONS -fglasgow-exts #-} -- ^ pattern type annotions -- -- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as -- published by the Free Software Foundation; either version 2 of -- the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -- -- -- Read in issue skeletons, generating html, wiki and txt versions, -- and updating the announce page. -- import Data.List import Text.PrettyPrint hiding (quotes) import Text.Printf import Control.Monad import System.Environment import System.Locale import System.Time import System.Cmd import System.Exit import System.IO import System.Directory import Control.Concurrent import Control.Exception import Debug.Trace import qualified Data.ByteString.Char8 as B -- -- The HWN data type -- data HWN = HWN { editorial :: (Maybe Editorial) , announce :: Announce , haskellprime :: HaskellPrime , libraries :: Libraries , conferences :: Conferences , discussion :: Discussion , jobs :: Jobs , blogs :: Blogs , quotes :: Quotes , commits :: Commits } deriving (Read,Show) type Editorial = String -- hwn sections newtype Announce = Announce [Item] deriving (Read,Show) newtype Jobs = Jobs [Item] deriving (Read,Show) newtype Discussion = Discussion [Item] deriving (Read,Show) newtype HaskellPrime = HaskellPrime [Link] deriving (Read,Show) newtype Libraries = Libraries [Link] deriving (Read,Show) newtype Quotes = Quotes [Quote] deriving (Read,Show) newtype Commits = Commits [Commit] deriving (Read,Show) newtype Blogs = Blogs [Link] deriving (Read,Show) data Conferences = Conferences (Maybe Title) [Item] deriving (Read,Show) type Title = String type Author = String type Body = String newtype Text = Text String deriving (Read,Show) type Who = String type Url = String type Date = String -- an item about something someone's done. data Item = Item Title Author Body deriving (Read,Show) data Quote = Quote Who Body deriving (Read,Show) data Link = Link Url Body deriving (Read,Show) data Commit = Commit Date Author Body deriving (Read,Show) -- and an issue type newtype Issue = Issue Int deriving (Read,Show) -- -- supported formats -- data Fmt = Html | Wiki | TeX -- a mini pretty printer class class Pretty a where ppr :: Fmt -> a -> Doc ------------------------------------------------------------------------ -- -- document header -- header :: Issue -> CalendarTime -> Fmt -> Doc header _ ct Wiki = (wikiquote $ text $ formatCalendarTime defaultTimeLocale "%Y-%m-%d" ct) <> char '\n' header (Issue n) ct TeX = vcat [ text "\\documentclass[a4paper]{article}" , text "\\pagestyle{empty}" , text "\\usepackage{url}" , text "\\usepackage{multicol}" , text "\\usepackage[left=1.8cm,top=3cm,right=1.8cm,nohead,nofoot]{geometry}" , text "\\usepackage{sectsty}" , text "\\usepackage{relsize}" , text "\\allsectionsfont{\\sffamily\\raggedright}" , text "\\begin{document}" , text "\\begin{figure}[t]" , text "\\hspace{0.2cm}" , text "\\begin{minipage}[t]{.55\\textwidth}" , text "\\flushleft" , text "\\Huge\\textbf{Haskell Weekly News}" , text "\\end{minipage}" , text "\\hfill" , text "\\raisebox{0.4cm}{" , text "\\begin{minipage}[t]{.40\\textwidth}" , text "\\flushright" , text $ (printf "Issue %d, " n) ++ (formatCalendarTime defaultTimeLocale "%B %d, %Y" ct) ++ "\\\\" , text "\\url{http://sequence.complete.org/}" , text "\\end{minipage}" , text "}" , text "\\hspace{0.5cm}" , text "\\hrule" , text "\\vspace{0.5cm}" , text "\\end{figure}" , text "\\setlength{\\columnsep}{0.5cm}" , text "\\setlength{\\multicolsep}{1cm}" , text "\\begin{multicols}{2}" , text "\\setcounter{unbalance}{3}" , text "\\raggedcolumns" ] header (Issue n) ct Html = prefix $$ empty $$ p ( text "Welcome to issue" <+> int n <+> text "of HWN, a weekly newsletter covering" $$ text "developments in the Haskell community." $$ empty ) where prefix = angle (text "!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"") $$ (tag "html" $ tag "head" $ tag "title" $ text ("Haskell Weekly News: "++show date)) $$ angle (text "body") date = text $ formatCalendarTime defaultTimeLocale "%B %d, %Y" ct ------------------------------------------------------------------------ -- -- document footer -- footer :: Fmt -> Doc footer Wiki = text "\n[[Old news|More news]]" footer TeX = vcat [ text "\\end{multicols}" , text "\\hrule" , text "\\end{document}" ] footer Html = tag "h4" (text "About the Haskell Weekly News") $$ empty $$ p ( text "Each week, new" <+> text "editions are posted to" $$ ppr Html (Link "http://www.haskell.org/mailman/listinfo/haskell" "the Haskell mailing list") $$ text "as well as to" $$ ppr Html (Link "http://sequence.complete.org/" "the Haskell Sequence") <+> text "and" $$ ppr Html (Link "http://planet.haskell.org/" "Planet Haskell") <> text "." $$ ppr Html (Link "http://sequence.complete.org/node/feed" "RSS") $$ text "is also available, and headlines appear on" <+> ppr Html (Link "http://haskell.org" "haskell.org") <> text "." <+> text "Headlines are available as PDF.") $$ p ( text "The Haskell Weekly News is also" <+> ppr Html (Link "http://haskell.org/haskellwiki/HWN/es" "available") <+> text "in Spanish translation." ) $$ p ( text "To help create new editions of this newsletter, please" $$ text "see the" <+> text "contributing" $$ text "information. Send stories to" <+> tag "code" (text "dons at cse.unsw.edu.au") <> text "." $+$ text "The darcs repository is available at" <+> tag "code" (text "darcs get http://www.cse.unsw.edu.au/~dons/code/hwn")) $$ text "" $$ text "" ------------------------------------------------------------------------ -- -- the content itself -- body :: HWN -> Fmt -> Doc body hwn Html = frontmatter $$ ppr Html (announce hwn) $+$ ppr Html (haskellprime hwn) $+$ ppr Html (libraries hwn) $+$ ppr Html (discussion hwn) $+$ ppr Html (conferences hwn) $+$ ppr Html (jobs hwn) $+$ ppr Html (blogs hwn) $+$ ppr Html (quotes hwn) $+$ ppr Html (commits hwn) where frontmatter = case editorial hwn of Just s -> p (text s) Nothing -> empty body hwn Wiki = ppr Wiki (announce hwn) body hwn TeX = ppr TeX (announce hwn) ------------------------------------------------------------------------ instance Pretty Announce where ppr Html (Announce items) = tag "h4" (text "Announcements") $$ tag "ul" (vcat (map (ppr Html) items)) ppr TeX (Announce items) = vcat $ intersperse (char ' ') $ map (ppr TeX) items ppr Wiki (Announce items) = tag "ul" $ vcat $ intersperse (char ' ') $ map (ppr Wiki) items instance Pretty Jobs where ppr _ (Jobs []) = empty ppr _ (Jobs items) = tag "h4" (text "Jobs") $$ tag "ul" (vcat (map (ppr Html) items)) instance Pretty HaskellPrime where ppr Html (HaskellPrime links) = tag "h4" (text "Haskell'") $$ text "This section covers the" <+> a "http://hackage.haskell.org/trac/haskell-prime" "Haskell'" <+> text "standardisation process." $$ tag "ul" (vcat (map (tag "li" . ppr Html) links)) instance Pretty Libraries where ppr Html (Libraries links) = tag "h4" (text "Libraries") $$ text "This week's proposals and extensions to the " <+> a "http://haskell.org/haskellwiki/Library_submissions" "standard libraries." $$ tag "ul" (vcat (map (tag "li" . ppr Html) links)) instance Pretty Blogs where ppr Html (Blogs links) = tag "h4" (text "Blog noise") $$ a "http://planet.haskell.org" "Haskell news" <+> text "from the blogosphere." $$ tag "ul" (vcat (map (tag "li" . ppr Html) links)) instance Pretty Discussion where ppr Html (Discussion items) = tag "h4" (text "Discussion") $$ tag "ul" (vcat (map (ppr Html) items)) instance Pretty Conferences where ppr Html (Conferences _ []) = empty ppr Html (Conferences mtitle items) = tag "h4" (text "Conference roundup") $$ (case mtitle of Nothing -> empty ; Just title -> (ppr Html (Text title))) $$ tag "ul" (vcat (map (ppr Html) items)) instance Pretty Quotes where ppr Html (Quotes []) = empty ppr Html (Quotes items) = tag "h4" (text "Quotes of the Week") $$ tag "ul" (vcat (map (ppr Html) items)) instance Pretty Item where ppr TeX (Item title author txt) = (text $ "\\section*{" ++ title ++ "}") $$ (text author) <+> ppr TeX (Text txt) ppr m (Item title author txt) = tag "li" $ p $ (tag "em" (text title)) <> char '.' <+> (text author) $$ ppr m (Text txt) instance Pretty Commits where ppr Html (Commits []) = empty ppr Html (Commits items) = tag "h4" (text "Code Watch") $$ tag "ul" (vcat (map (ppr Html) items)) instance Pretty Commit where ppr m (Commit date author txt) = tag "li" $ p $ (tag "em" (text date)) <> char '.' <+> tag "em" (text author) <> char '.' <+> ppr m (Text txt) instance Pretty Text where ppr Wiki (Text s) = text s ppr TeX (Text s ) = text $ polish s where polish :: String -> String -- strip the urls polish [] = [] polish ('[':xs) = let (_ ,ys) = break (==' ') xs (txt,zs) = break (==']') (tail ys) in txt ++ polish (if null zs then zs else tail zs) polish (x:xs) = x : polish xs ppr Html (Text s) = text $ hrefify s where -- wiki refs to html 's hrefify :: String -> String hrefify [] = [] hrefify ('[':xs) = let (url,ys) = break (==' ') xs (txt,zs) = break (==']') (tail ys) in ""++txt++""++ hrefify (if null zs then zs else tail zs) hrefify (x:xs) = x : hrefify xs instance Pretty Link where ppr Html (Link url txt) = a (show url) txt ppr Wiki (Link url txt) = brackets (text url <+> text txt) instance Pretty Quote where ppr Html (Quote who txt) = tag "li" $ tag "em" (text who) <> colon <+> text txt ------------------------------------------------------------------------ -- html and wiki mark up combinators -- wrap text in a tag tag :: String -> Doc -> Doc tag s t = angle (text s) <> t <> angle (text ('/' : s)) a :: String -> String -> Doc a ref txt = angle (text $ "a href="++ ref) <> text txt <> angle (text "/a") p :: Doc -> Doc p txt = tag "p" txt angle :: Doc -> Doc angle x = char '<' <> x <> char '>' wikiquote :: Doc -> Doc wikiquote x = tics <> x <> tics where tics = text "''" ------------------------------------------------------------------------ -- print the whole thing typeset :: HWN -> Issue -> CalendarTime -> Fmt -> Doc typeset content issue time mode = header issue time mode $$ body content mode $$ footer mode -- let's go main = do args <- getArgs let publish = args == ["-p"] -- first, run the spell checker, if we're going to pubish when publish $ run $ "aspell -c content.wiki" -- get the issue (issue :: Issue) <- readFile "issue" >>= readIO -- get the content (content :: HWN) <- readFile "content.wiki" >>= readIO . tweak -- get the date time <- getClockTime >>= toCalendarTime let html = typeset content issue time Html wiki = typeset content issue time Wiki tex = typeset content issue time TeX -- archive html version let stub = formatCalendarTime defaultTimeLocale "%Y%m%d" time htmlfile = stub <.> "html" wikifile = stub <.> "wiki" txtfile = stub <.> "txt" texfile = stub <.> "tex" dvifile = stub <.> "dvi" pdffile = stub <.> "pdf" writeFile htmlfile $ render html writeFile wikifile $ render wiki writeFile texfile $ render tex -- generate txt version run $ "utils/totext.sh " ++ htmlfile -- generate .pdf version run $ "latex " ++ texfile run $ "dvipdf " ++ dvifile -- clean up html version (works around sequence.org bug with line wrapping) run $ "fmt -80 " ++ htmlfile ++ " > /tmp/publish.xxyyzz ; mv /tmp/publish.xxyyzz " ++ htmlfile -- and bump the announce file -- if 'publish' actually writes files into the archives when publish $ do -- and edit the text file (fixing the refs. a couple of minutes work) run $ "xterm -e vim -o " ++ txtfile ++ " " ++ txtfile -- move into archives/ renameFile htmlfile $ "archives" htmlfile renameFile txtfile $ "archives" txtfile renameFile texfile $ "archives" texfile renameFile pdffile $ "archives" pdffile -- bump old wiki news -- strictly read files with bytestring, since we write back as well n <- B.readFile $ "wiki" "News.html" o <- B.readFile $ "wiki" "Old_news.html" -- generate new Old_news.html page let (hd,tl) = splitAt 4 (B.lines o) news = B.lines n -- splice in last week's new news into old news B.writeFile ("wiki" "Old_news.html") (B.unlines $ hd ++ init news ++ tl) -- and move wikifile onto the old file renameFile wikifile $ "wiki" "News.html" -- and bump issue count writeFile "issue" $ show $ (\(Issue n) -> Issue (n+1)) issue -- add back some Haskell syntax tweak :: String -> String tweak s = "HWN {" ++ (f s) ++ "}" where f [] = [] f xs | "\n--" `isPrefixOf` xs = f (dropWhile (/= '\n') (tail xs)) | "Editorial" `isPrefixOf` xs = 'e' : f (tail xs) | "Quotes" `isPrefixOf` xs = "quotes = Quotes" ++ f (drop 6 xs) | "Discussion" `isPrefixOf` xs = "discussion = Discussion" ++ f (drop 10 xs) | "HaskellPrime" `isPrefixOf` xs = "haskellprime = HaskellPrime" ++ f (drop 12 xs) | "Announce" `isPrefixOf` xs = "announce = Announce" ++ f (drop 8 xs) | "Commits" `isPrefixOf` xs = "commits = Commits" ++ f (drop 7 xs) | "Blogs" `isPrefixOf` xs = "blogs = Blogs" ++ f (drop 5 xs) | "Conferences" `isPrefixOf` xs = "conferences = Conferences" ++ f (drop 11 xs) | "Jobs" `isPrefixOf` xs = "jobs = Jobs" ++ f (drop 4 xs) | "Libraries" `isPrefixOf` xs = "libraries = Libraries" ++ f (drop 9 xs) f (x:xs) = x : f xs ------------------------------------------------------------------------ -- run a program, check the exit status run :: String -> IO () run s = do v <- system s when (v /= ExitSuccess) $ error $ s ++ ": returned non-zero status" -- -- | join two path components -- infixr 6 <.> infixr 6 (<.>), () :: FilePath -> FilePath -> FilePath [] <.> b = b a <.> b = a ++ "." ++ b [] b = b a b = a ++ "/" ++ b