1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE DuplicateRecordFields #-}
7 import Data.Function (on)
8 import Data.List (sort, sortBy, groupBy)
9 import Data.Ord (comparing)
10 import Data.String hiding (lines)
11 import Data.Text hiding (groupBy, map, concat, foldl, head, splitAt, filter, zip, length, reverse)
12 import Data.Text.Lazy (toStrict)
13 import Data.Text.Template
14 import Data.Time.Clock
15 import Data.Time.Clock.POSIX
16 import Data.Time.Format
17 import Data.Time.LocalTime
18 import Prelude hiding (lines)
19 import System.Directory
20 import System.FilePath.Posix (takeBaseName, takeDirectory)
26 name :: Text, -- works better with getHomeDirectory
27 templates :: [(Text, Template)]
30 data Project = Project {
37 data BlogEntry = BlogEntry {
44 type EntryList = [(Text, [(Text, [(Text, BlogEntry)])])]
46 format t format = fromString $ formatTime defaultTimeLocale format $ utcToLocalTime (hoursToTimeZone 8) t
48 myGroup :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
49 myGroup = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst) . sortBy (comparing fst)
51 myGroupNoSort :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
52 myGroupNoSort = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst)
54 stampsToEntryList :: [BlogEntry] -> EntryList
55 stampsToEntryList stamps = map (\(a,b) -> (a, reverse $ map (\(c,d) -> (c, reverse $ map (\(x, y) -> ("0" `append` (fromString . show) x, y)) $ zip [1..] d)) b)) $
56 map (\(a, b) -> (a, myGroupNoSort b)) $
57 map (\(a, b) -> (a, concat b)) $ myGroupNoSort $
59 c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
61 getEntriesTemplate :: Project -> Template
62 getEntriesTemplate p = case lookup "entry.html" $ templates $ theme (p :: Project) of
65 getEntriesVideoTemplate :: Project -> Template
66 getEntriesVideoTemplate p = case lookup "entry-video.html" $ templates $ theme (p :: Project) of
69 getTemplateForEntry :: Project -> BlogEntry -> Template
70 getTemplateForEntry p e = case video e of
71 Just _ -> getEntriesVideoTemplate p
72 Nothing -> getEntriesTemplate p
74 getIndexTemplate :: Project -> Template
75 getIndexTemplate p = case lookup "index.html" $ templates $ theme (p :: Project) of
78 getEntryPages :: Project -> [(Text, Text)]
79 getEntryPages p = concat $ concat $ map (\(year, months)
80 -> map (\(month, entries)
81 -> map (\(entryNum, entry) ->
84 format (postDate entry) "%Y",
85 format (postDate entry) "%B",
86 urlify (title entry) `append` ".html"],
87 entryToMarkup entry (getTemplateForEntry p entry))
88 ) entries) months) (entries p)
90 entryListToIndex :: EntryList -> Text
91 entryListToIndex el = unorderedList Nothing $ map (\(year, monthList) -> unorderedList (Just year) $ map (\(month, entryList) -> unorderedList (Just month) $ map (\x -> "<a href=\"" <> year <> "/" <> month <> "/" <> ((urlify . title . snd) x) <> ".html\">" <> (title . snd) x <> "</a>") entryList) monthList) el
93 i2t :: Integer -> Text
94 i2t = (fromString . show)
96 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
98 entryToMarkup entry template = toStrict $ render template tmplContext
100 tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
103 Just a -> [("video", a)]
105 wrapInTags :: Text -> [Text] -> Text
106 wrapInTags tag = foldMap $ (<> close) . (open <>)
107 where close = "</" `append` tag `append` ">"
108 open = "<" `append` tag `append` ">"
110 paragraphs = wrapInTags "p"
112 unorderedList :: Maybe Text -> [Text] -> Text
113 unorderedList heading items = case heading of
114 Just x -> x `append` unorderedList Nothing items
115 Nothing -> "<ul>" `append` (wrapInTags "li" items) `append` "</ul>"
117 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
119 metaMap = zip [0..] meta
120 meta = splitOn "::" (fileLines !! 0)
121 fileLines = lines rawEntry
123 writeOutProject projectConfig files = do
124 files <- fmap (reverse . sort) $ allFilesIn "entries"
125 rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files
126 entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries
127 homeDir <- getHomeDirectory
129 let themeName = unpack $ theme (projectConfig :: ProjectConfig)
130 themeTemplatePaths <- allFilesIn $ homeDir ++ "/.xyz/themes/" ++ themeName
131 themeTemplates <- mapM (\x -> (readFile $ homeDir ++ "/.xyz/themes/" ++ themeName ++ "/" ++ x) >>= (\y -> return (pack x, (template . fromString) y))) themeTemplatePaths
133 let projectName = name (projectConfig :: ProjectConfig)
134 let projectDescription = description (projectConfig :: ProjectConfig)
135 let project = Project projectName projectDescription (Theme (pack themeName) themeTemplates) (stampsToEntryList entryList)
137 mapM_ (createDirectoryIfMissing True . takeDirectory . unpack . fst) $ getEntryPages project
138 mapM_ (\x -> writeFile (unpack $ fst x) (unpack $ snd x)) $ getEntryPages project
139 writeFile "build/index.html" $ unpack $ toStrict $ render (getIndexTemplate project) $ context [("index", entryListToIndex (entries project))]