1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE DuplicateRecordFields #-}
8 import Data.Function (on)
9 import Data.List (sort, sortBy, groupBy)
10 import Data.Ord (comparing)
11 import Data.String hiding (lines)
12 import Data.Text hiding (groupBy, map, concat, foldl, head, splitAt, filter, zip, length, reverse)
13 import Data.Text.Lazy (toStrict)
14 import Data.Text.Template
15 import Data.Time.Clock
16 import Data.Time.Clock.POSIX
17 import Data.Time.Format
18 import Data.Time.LocalTime
19 import Prelude hiding (lines)
20 import System.Directory
21 import System.FilePath.Posix (takeBaseName, takeDirectory)
26 name :: String, -- works better with getHomeDirectory
27 templates :: [(String, Template)]
30 data ProjectConfig = ProjectConfig {
33 theme :: String -- as above
34 } deriving (Show, Data, Typeable)
36 data Project = Project {
43 data BlogEntry = BlogEntry {
50 type EntryList = [(Text, [(Text, [(Text, BlogEntry)])])]
52 format t format = fromString $ formatTime defaultTimeLocale format $ utcToLocalTime (hoursToTimeZone 8) t
54 myGroup :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
55 myGroup = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst) . sortBy (comparing fst)
57 myGroupNoSort :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
58 myGroupNoSort = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst)
60 stampsToEntryList :: [BlogEntry] -> EntryList
61 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)) $
62 map (\(a, b) -> (a, myGroupNoSort b)) $
63 map (\(a, b) -> (a, concat b)) $ myGroupNoSort $
65 c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
67 getEntriesTemplate :: Project -> Template
68 getEntriesTemplate p = case lookup "entry.html" $ templates $ theme (p :: Project) of
71 getEntriesVideoTemplate :: Project -> Template
72 getEntriesVideoTemplate p = case lookup "entry-video.html" $ templates $ theme (p :: Project) of
75 getTemplateForEntry :: Project -> BlogEntry -> Template
76 getTemplateForEntry p e = case video e of
77 Just _ -> getEntriesVideoTemplate p
78 Nothing -> getEntriesTemplate p
80 getIndexTemplate :: Project -> Template
81 getIndexTemplate p = case lookup "index.html" $ templates $ theme (p :: Project) of
84 getEntryPages :: Project -> [(Text, Text)]
85 getEntryPages p = concat $ concat $ map (\(year, months)
86 -> map (\(month, entries)
87 -> map (\(entryNum, entry) ->
90 format (postDate entry) "%Y",
91 format (postDate entry) "%B",
92 urlify (title entry) `append` ".html"],
93 entryToMarkup entry (getTemplateForEntry p entry))
94 ) entries) months) (entries p)
96 entryListToIndex :: EntryList -> Text
97 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
99 i2t :: Integer -> Text
100 i2t = (fromString . show)
102 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
104 entryToMarkup entry template = toStrict $ render template tmplContext
106 tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
109 Just a -> [("video", a)]
111 wrapInTags :: Text -> [Text] -> Text
112 wrapInTags tag = foldMap $ (<> close) . (open <>)
113 where close = "</" `append` tag `append` ">"
114 open = "<" `append` tag `append` ">"
116 paragraphs = wrapInTags "p"
118 unorderedList :: Maybe Text -> [Text] -> Text
119 unorderedList heading items = case heading of
120 Just x -> x `append` unorderedList Nothing items
121 Nothing -> "<ul>" `append` (wrapInTags "li" items) `append` "</ul>"
123 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
125 metaMap = zip [0..] meta
126 meta = splitOn "::" (fileLines !! 0)
127 fileLines = lines rawEntry
129 writeOutProject projectConfig files = do
130 files <- fmap (reverse . sort) $ allFilesIn "entries"
131 rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files
132 entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries
133 homeDir <- getHomeDirectory
135 let themeName = theme (projectConfig :: ProjectConfig)
136 themeTemplatePaths <- allFilesIn $ homeDir ++ "/.xyz/themes/" ++ themeName
137 themeTemplates <- mapM (\x -> (readFile $ homeDir ++ "/.xyz/themes/" ++ themeName ++ "/" ++ x) >>= (\y -> return (x, (template . fromString) y))) themeTemplatePaths
139 let projectName = name (projectConfig :: ProjectConfig)
140 let projectDescription = description (projectConfig :: ProjectConfig)
141 let project = Project projectName projectDescription (Theme themeName themeTemplates) (stampsToEntryList entryList)
143 mapM_ (createDirectoryIfMissing True . takeDirectory . unpack . fst) $ getEntryPages project
144 mapM_ (\x -> writeFile (unpack $ fst x) (unpack $ snd x)) $ getEntryPages project
145 writeFile "build/index.html" $ unpack $ toStrict $ render (getIndexTemplate project) $ context [("index", entryListToIndex (entries project))]