#!/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 Data.Ord (comparing) 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 repo = "http://code.haskell.org/~byorgey/code/hwn/" editor = "byorgey at cis dot upenn dot edu" -- -- The HWN data type -- data HWN = HWN { editorial :: (Maybe Editorial) , community :: Community , announce :: Announce -- , gsoc :: GSoC -- TMP , 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 Community = Community [Text] deriving (Read,Show) newtype Announce = Announce [Item] deriving (Read,Show) -- newtype GSoC = GSoC [Item] deriving (Read,Show) -- TMP newtype Jobs = Jobs [Item] deriving (Read,Show) newtype Discussion = Discussion [Item] deriving (Read,Show) newtype HaskellPrime = HaskellPrime [Link] deriving (Read,Show) newtype Libraries = Libraries [Item] deriving (Read,Show) newtype Quotes = Quotes [Quote] deriving (Read,Show) newtype Commits = Commits [Commit] deriving (Read,Show) newtype Blogs = Blogs [Post] 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 Quote = Quote Who Body deriving (Read,Show) data Link = Link Url Body deriving (Read,Show) data Commit = Commit Date Author Body deriving (Read,Show) -- The status of a blog post data Status = N -- a Normal post | NP -- a Non-Planet blog, give them some love! | H -- a particularly excellent post to Highlight deriving (Read,Show) -- a blog post, with a date, title, description, and status flag data Post = Post Date Author Title Body Url Status deriving (Read,Show) date :: Post -> Date date (Post d _ _ _ _ _) = d -- 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 ((repo "archives/") ++ date) "PDF")) <> text "." -} ) $$ p ( text "To help create new editions of this newsletter, please" $$ text "see the information on" <+> text "how to" $$ text "contribute. Send stories to" <+> tag "code" (text editor) <> text "." $+$ text "The darcs repository is available at" <+> tag "code" (text "darcs get" <+> ppr Html (Link repo repo) <+> text ".") ) $$ text "" $$ text "" where date = formatCalendarTime defaultTimeLocale "%Y%m%d.pdf" ct ------------------------------------------------------------------------ -- -- the content itself -- body :: HWN -> Fmt -> Doc body hwn Html = frontmatter $$ ppr Html (community hwn) $+$ ppr Html (announce hwn) $+$ -- ppr Html (gsoc hwn) $+$ -- TMP 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 $ ppr Html (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 Community where ppr _ (Community []) = empty ppr Html (Community items) = tag "h4" (text "Community News") $$ vcat (map (tag "p" . ppr Html) items) ppr TeX (Community items) = vcat $ intersperse (char ' ') $ map (ppr TeX) items ppr Wiki (Community items) = tag "ul" $ vcat $ intersperse (char ' ') $ map (tag "li" . ppr Wiki) items 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 -- TMP {- gsoc_url = "http://hackage.haskell.org/trac/summer-of-code/wiki/SoC2008" instance Pretty GSoC where ppr _ (GSoC []) = empty ppr Html (GSoC items) = tag "h4" (text "Google Summer of Code") $$ tag "p" (text "Progress updates from participants in the 2008" <+> a' gsoc_url (text "Google Summer of Code.")) $$ vcat (map (ppr Html) items) ppr TeX (GSoC items) = vcat $ intersperse (char ' ') $ map (ppr TeX) items ppr Wiki (GSoC items) = tag "ul" $ vcat $ intersperse (char ' ') $ map (tag "li" . ppr Wiki) items -- TMP -} 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 items) = tag "h4" (text "Libraries") $$ text "Proposals and extensions to the " <+> a "http://haskell.org/haskellwiki/Library_submissions" "standard libraries." $$ vcat (map (ppr Html) items) instance Pretty Blogs where ppr _ (Blogs []) = empty ppr Html (Blogs posts) = tag "h4" (text "Blog noise") $$ a "http://planet.haskell.org" "Haskell news" <+> text "from the " <+> a "http://haskell.org/haskellwiki/Blog_articles" "blogosphere." <+> text "Blog posts from people new to the Haskell community are marked with >>>, be sure to welcome them!" $$ (tag "ul" . vcat . map (tag "li" . ppr Html) . sortBy (flip $ comparing date) $ posts) 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)) <> (if last title `elem` ".!?" then text "" else char '.') <+> (text author) $$ 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 instance Pretty Post where ppr Html (Post _ who title desc url flag) = p $ mark flag who <> colon <+> a' url (tag "em" (text title)) <> char '.' <+> ppr Html (Text desc) where mark N w = text w mark NP w = text ">>>" <+> text w mark H w = text "++" <> text w <> text "++" ------------------------------------------------------------------------ -- 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 = a' ref (text txt) a' :: String -> Doc -> Doc a' ref txt = angle (text $ "a href=\""++ ref ++ "\"") <> 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 -- 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 {" ++ (unlines . map f . lines $ s) ++ "}" where f xs | "--" `isPrefixOf` xs = "" | "Editorial" `isPrefixOf` xs = 'e': tail xs | "Quotes" `isPrefixOf` xs = "quotes = " ++ xs | "Discussion" `isPrefixOf` xs = "discussion = " ++ xs | "HaskellPrime" `isPrefixOf` xs = "haskellprime = " ++ xs | "Community" `isPrefixOf` xs = "community = " ++ xs | "Announce" `isPrefixOf` xs = "announce = " ++ xs -- | "GSoC" `isPrefixOf` xs = "gsoc = " ++ xs -- TMP | "Commits" `isPrefixOf` xs = "commits = " ++ xs | "Blogs" `isPrefixOf` xs = "blogs = " ++ xs | "Conferences" `isPrefixOf` xs = "conferences = " ++ xs | "Jobs" `isPrefixOf` xs = "jobs = " ++ xs | "Libraries" `isPrefixOf` xs = "libraries = " ++ xs | otherwise = 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 | last a == '.' = a ++ b | otherwise = a ++ "." ++ b [] b = b a b | last a == '/' = a ++ b | otherwise = a ++ "/" ++ b