#!/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 , hackage :: Hackage , 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 Hackage = Hackage [HackageItem] 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) [Link] 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 HackageItem = HackageItem 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=4cm,bottom=2cm,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 newsletter covering" $$ text "developments in the " <> (ppr Html (Link "http://haskell.org/" "Haskell")) <> text " community.") $$ empty where prefix = angle (text "!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"") $$ (text "" <> (text "") <> (tag "title" $ text ("Haskell Weekly News: "++show date)) <> text "" <> angle (text "body")) date = text $ formatCalendarTime defaultTimeLocale "%B %d, %Y" ct ------------------------------------------------------------------------ -- -- document footer -- footer :: CalendarTime -> Fmt -> Doc footer _ Wiki = text "\n[[Old news|More news]]" footer _ TeX = vcat [ text "\\end{multicols}" , text "\\vspace*{\\fill}" , text "\\hrule" , text "\\hspace{0.5cm}" , text "\\flushleft" , text "\\begin{minipage}[t]{\\textwidth}" , text "\\flushleft" , text "\\textbf{Choose higher order, polymorphic and purely functional. Choose Haskell.} \\\\" , text "\\url{http://haskell.org/} \\\\" , text "\\end{minipage}" , text "\\end{document}" ] footer ct Html = tag "h4" (text "About the Haskell Weekly News") $$ empty $$ p ( text "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" <+> (ppr Html (Link ("http://www.cse.unsw.edu.au/~dons/code/hwn/archives/" ++ date) "PDF")) <> text "." ) $$ 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 galois.com") <> text "." $+$ text "The darcs repository is available at" <+> tag "code" (text "darcs get" <+> ppr Html (Link "http://www.cse.unsw.edu.au/~dons/code/hwn" "http://www.cse.unsw.edu.au/~dons/code/hwn"))) $$ text "" $$ text "" where date = formatCalendarTime defaultTimeLocale "%Y%m%d.pdf" ct ------------------------------------------------------------------------ -- -- the content itself -- body :: HWN -> Fmt -> Doc body hwn Html = frontmatter $$ ppr Html (announce hwn) $+$ ppr Html (hackage 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) $+$ -- ppr TeX (conferences hwn) $+$ ppr TeX (jobs hwn) $+$ ppr TeX (quotes hwn) ------------------------------------------------------------------------ instance Pretty Announce where ppr _ (Announce []) = empty ppr Html (Announce items) = tag "h4" (text "Announcements") $$ 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 (tag "li" . ppr Wiki) items instance Pretty Jobs where ppr _ (Jobs []) = empty ppr TeX (Jobs items) = vcat [ text "\\bigskip" , text "\\hrule" , text "\\section*{Jobs}" ] $$ vcat (map (ppr TeX) items) ppr Html (Jobs items) = tag "h4" (text "Jobs") $$ (vcat (map (ppr Html) items)) instance Pretty HaskellPrime where ppr _ (HaskellPrime []) = empty 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 _ (Libraries []) = empty 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 Hackage where ppr _ (Hackage []) = empty ppr Html (Hackage items) = tag "h4" (text "Hackage") $$ text "This week's new libraries in " <+> a "http://hackage.haskell.org/" "the Hackage library database." $$ tag "ul" (vcat (map (tag "li" . ppr Html) items)) instance Pretty Blogs where ppr _ (Blogs []) = empty ppr Html (Blogs links) = tag "h4" (text "Blog noise") $$ a "http://planet.haskell.org" "Haskell news" <+> text "from the " <+> a "http://haskell.org/haskellwiki/Blog_articles" "blogosphere." $$ tag "ul" (vcat (map (tag "li" . ppr Html) (links))) {- url :: Link -> Link -> Ordering url (Link u a) (Link v b) | EQ <- x = a `compare` b | otherwise = x where x = u `compare` v -} instance Pretty Discussion where ppr _ (Discussion []) = empty ppr Html (Discussion items) = tag "h4" (text "Discussion") $$ vcat (map (ppr Html) items) instance Pretty Conferences where ppr _ (Conferences _ []) = empty {- ppr TeX (Conferences mtitle items) = vcat [ text "\\bigskip" , text "\\hrule" , text "\\section*{Conferences}" ] $$ (case mtitle of Nothing -> empty ; Just title -> (ppr TeX (Text title))) $$ (vcat (map (ppr TeX) items)) -} 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 (tag "li" . ppr Html) items)) instance Pretty Quotes where ppr _ (Quotes []) = empty ppr TeX (Quotes quotes) = vcat [ text "\\bigskip" , text "\\hrule" , text "\\section*{Quotes}" , text "\\begin{itemize}" ] $$ vcat (map (ppr TeX) quotes) $$ text "\\end{itemize}" ppr Html (Quotes items) = tag "h4" (text "Quotes of the Week") $$ tag "ul" (vcat (map (tag "li" . 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) = p $ (tag "em" (text title)) <> char '.' <+> (text author) $$ ppr m (Text txt) instance Pretty HackageItem where ppr TeX (HackageItem title author txt) = (text $ "\\section*{" ++ title ++ "}") $$ (text author) <+> ppr TeX (Text txt) ppr m (HackageItem title author txt) = p $ (tag "em" (text title)) <> text ". Uploaded by" <+> (text author) <> char '.' $$ ppr m (Text txt) instance Pretty Commits where ppr Html (Commits []) = empty ppr Html (Commits items) = tag "h4" (text "Code Watch") $$ text "Notable new features and bug fixes to the Haskell compilers." <+> vcat (map (ppr Html) items) instance Pretty Commit where ppr m (Commit date author txt) = 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 "[]" = [] 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 "[]" = [] 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 url txt ppr Wiki (Link url txt) = brackets (text url <+> text txt) instance Pretty Quote where ppr TeX (Quote who txt) = text "\\item \\emph" <> braces(text who) <+> text (teXesc txt) ppr Html (Quote [] txt) = text txt ppr Html (Quote who txt) = 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 "''" teXesc :: String -> String teXesc xs = (\c -> if c == '#' then "\\#" else [c]) =<< xs {- 11:38 dons> sjanssen: you have 60 seconds: give me this as a fold. 11:38 dons> teXesc [] = [] 11:38 dons> teXesc ('#':xs) = '\\':'#':teXesc xs 11:38 dons> teXesc (x :xs) = x : teXesc xs 11:39 sjanssen> > foldr (\x xs -> if x == '#' then '\\':'#':xs else xs) [] "#stuff$#" 11:39 lambdabot> "\\#\\#" 11:40 Pseudonym> > foldr (\c -> if c == '#' then ("\\#"++) else (c:)) [] "#stuff##" 11:40 lambdabot> "\\#stuff\\#\\#" 11:41 Pseudonym> > "#stuff##" >>= \c -> if c == '#' then "\\#" else [c] 11:41 lambdabot> "\\#stuff\\#\\#" -} ------------------------------------------------------------------------ -- print the whole thing typeset :: HWN -> Issue -> CalendarTime -> Fmt -> Doc typeset content issue time mode = header issue time mode $$ body content mode $$ footer time 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 -- and validate putStr "Validating ... " >> hFlush stdout run $ "validate -w " ++ htmlfile putStrLn "done." -- 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 -- 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 copyFile "content.wiki" $ "archives" wikifile -- 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 -- keep a backup copyFile "content.wiki" "content.wiki.old" copyFile "content.pristine" "content.wiki" -- 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) | "Hackage " `isPrefixOf` xs = "hackage = Hackage " ++ f (drop 8 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