Commits

Colin Barrett  committed 7b2d996

Large refactor of how stories are represented.

Stories are now represented in the Story data type, and that data type is now used in the StoryR constructor. This makes changing and organizing the index page much easier.

  • Participants
  • Parent commits ebff2a6

Comments (0)

Files changed (6)

File SmallStories/Component/Index.hs

   ) where
 
 import Data.Text as T
+import qualified Data.Map as M
+import Data.Map ((!))
 import SmallStories.Component
 import SmallStories.Component.Header
 import SmallStories.Route
+import SmallStories.Story
+import SmallStories.WordCount
 import Text.Cassius
+import Text.Pandoc
 
 -- route, title, count
-indexComponent :: [(Route, Text, Int)] -> Component Route ()
-indexComponent stories = do
+indexComponent :: M.Map Story Pandoc -> Component Route ()
+indexComponent ps = do
   [chamlet|$newline never
     ^{headerComponent}
     <dl>
-      $forall (route, title, count) <- stories
-        <dt><a href="@{route}">#{title}</a>
-        <dd>#{show count} words|]
+      ^{story LFrankOz}
+      ^{story YoungPalms}
+      ^{story PasteEater}|]
+
   toComponent [cassius|
     dl
       width: 560px
       content: "#{T.replicate 66 " ."} "
     dd
       margin-bottom: 2em|]
+  
+  where story s = indexStoryComponent s (ps ! s)
+
+indexStoryComponent :: Story -> Pandoc -> Component Route ()
+indexStoryComponent s p = [chamlet|$newline never
+  <dt><a href="@{StoryR s}">#{renderTitle p}</a>
+  <dd>#{show (wordCount p)} words|]

File SmallStories/Component/Story.hs

 import SmallStories.Component
 import SmallStories.Component.Header
 import SmallStories.Route
+import SmallStories.Story
 import Text.Blaze.Html
 import Text.Cassius
+import Text.Pandoc
 
-storyComponent :: Text -> Text -> Html -> Component Route ()
-storyComponent slug title body = do
+storyComponent :: Pandoc -> Component Route ()
+storyComponent p = do
   [chamlet|
     ^{headerComponent}
-    <h3>#{title}
+    <h3>#{renderTitle p}
     <hr>
-    ^{body}
+    ^{writeHtml def p}
     <hr>|]
   toComponent [cassius|
     p

File SmallStories/Main.hs

 
 import Control.Monad
 import qualified Data.ByteString as B
+import qualified Data.Map as M
+import Data.Map ((!))
 import Data.Functor ((<$>))
 import Data.Maybe
 import Data.Monoid (mempty)
 import SmallStories.Page
 import SmallStories.Route
 import SmallStories.Route.Static
+import SmallStories.Story
 import SmallStories.WordCount
 import System.Console.CmdArgs as C
 import System.Directory
 import System.FilePath
 
-pageAction :: Page -> FilePath -> IO ()
-pageAction (IndexP ts) p = writeComponent p $ indexComponent ts
-pageAction (AboutP) p = writeComponent p $ aboutComponent
-pageAction (StoryP s t h) p = writeComponent p $ storyComponent s t h
-pageAction (StaticP t b) p = B.writeFile p b
-
 writeComponent :: FilePath -> Component Route () -> IO ()
 writeComponent p c = writeFile p $ renderComponent layout c renderRoute
   where layout pc = [hamlet|$newline never
                           <script type="text/javascript">try{Typekit.load();}catch(e){}</script>
                         <body>^{pcHtml pc}|]
 
-storyPaths :: FilePath -> Maybe FilePath -> IO [FilePath]
-storyPaths storiesDir indexOrder =
-  if isJust indexOrder then do
-    contents <- readFile (fromJust indexOrder)
-    filterM doesFileExist $ (storiesDir </>) <$> lines contents
-  else do
-    contents <- getDirectoryContents storiesDir
-    return [ storiesDir </> p | p <- contents, takeExtension p == ".md" ]
 
-allPages :: FilePath -> Maybe FilePath -> IO [Page]
-allPages storiesDir indexOrder = do
-  paths <- storyPaths storiesDir indexOrder
-  let slugs = takeBaseName <$> paths
-  pandocs <- (parseMarkdown <=< readFile) `mapM` paths
-  let titles = renderTitle <$> pandocs
-  return $ [IndexP (zipWith3 buildIndex slugs titles pandocs)]
-        ++ [AboutP]
-        ++ zipWith3 buildStory slugs titles pandocs
-        ++ allStaticPages
-  where
-    parseMarkdown = return . readMarkdown P.def { readerExtensions = multimarkdownExtensions }
-    buildIndex s t p = (StoryR (pack s), t, wordCount p)
-    renderTitle (Pandoc (Meta title _ _) _) = pack $ writePlain P.def (Pandoc emptyMeta [Plain title])
-    emptyMeta = Meta mempty mempty mempty
-    buildStory s t p = StoryP (pack s) t (writeHtml P.def p)
-    
+ 
 fixupDir :: FilePath -> Bool -> IO FilePath
 fixupDir dir create = do
   when create $ createDirectoryIfMissing True dir
 buildAction options = do
   outputDir <- fixupDir (output options) True
   storiesDir <- fixupDir (stories options) False
-  pages <- allPages storiesDir (indexOrder options)
-  let paths = ((outputDir </>) . pageFilePath) <$> pages
-  zipWithM_ pageAction pages paths
+  storyMap <- storyPandocs storiesDir
+  
+  -- Write components
+  writeComponent (pfp outputDir IndexP) $ indexComponent storyMap
+  writeComponent (pfp outputDir AboutP) $ aboutComponent
+  allStoryPages storyMap `forM_` \page@(StoryP _ pandoc) -> do
+    writeComponent (pfp outputDir page) $ storyComponent pandoc
+  
+  -- Write static pages
+  mapM_ (writeStaticPage outputDir) allStaticPages
+  
+  where pfp o p = o </> pageFilePath p
+        writeStaticPage o p@(StaticP _ b) = B.writeFile (o </> pageFilePath p) b
 
 data Command = Build { output :: String
                      , stories :: String

File SmallStories/Page.hs

   ( Page(..)
   , pageFilePath
   , allStaticPages
+  , allStoryPages
   ) where
 
 import qualified Data.ByteString as B
+import Data.Functor
+import Data.Map (Map, (!))
 import Data.Text
-import Text.Blaze.Html
-import SmallStories.Route
+import Text.Pandoc
 import SmallStories.Static (staticPages)
+import SmallStories.Story
 
-data Page = IndexP ![(Route, Text, Int)]
+-- I think we can elimimate the page type completely!
+-- The only thing we need is a place to store filename and data of static files and that can just be in Static.hs itself
+data Page = IndexP
           | AboutP
-          | StoryP !Text !Text !Html
+          | StoryP !Story !Pandoc
           | StaticP !Text !B.ByteString
 
 pageFilePath :: Page -> FilePath
-pageFilePath (IndexP _) = "index.html"
+pageFilePath (IndexP) = "index.html"
 pageFilePath (AboutP) = "about.html"
-pageFilePath (StoryP slug _ _) = unpack slug ++ ".html"
+pageFilePath (StoryP s _) = (storySlug s) ++ ".html"
 pageFilePath (StaticP t _) = unpack t
 
 allStaticPages :: [Page]
 allStaticPages = $(staticPages "static")
+
+allStoryPages :: Map Story Pandoc -> [Page]
+allStoryPages ps = (\s -> StoryP s (ps ! s)) <$> [minBound..]

File SmallStories/Route.hs

   ) where
 
 import Data.Text
+import SmallStories.Story
 
 data Route = IndexR
            | AboutR
-           | StoryR !Text
+           | StoryR !Story
            | StaticR !Text
 
 renderRoute :: Route -> [(Text, Text)] -> Text
 renderRoute r _ = go r
   where go IndexR = "index.html"
         go AboutR = "about.html"
-        go (StoryR slug) = slug `append` ".html"
+        go (StoryR story) = (pack $ storySlug story) `append` ".html"
         go (StaticR t) = t

File SmallStories/Story.hs

+module SmallStories.Story
+  ( Story(..)
+  , storySlug
+  , storyPandoc
+  , storyPandocs
+  , renderTitle
+  ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Functor
+import Data.List
+import qualified Data.Map as M
+import Data.Monoid
+import Data.Text hiding (zip, zipWith)
+import Text.Pandoc
+import System.FilePath
+
+data Story = LFrankOz
+           | YoungPalms
+           | PasteEater
+           deriving (Show, Eq, Ord, Enum, Bounded)
+
+storySlug :: Story -> String
+storySlug LFrankOz   = "l-frank-oz"
+storySlug YoungPalms = "young-palms"
+storySlug PasteEater = "paste-eater"
+
+storyPandoc :: FilePath -> Story -> IO Pandoc
+storyPandoc storiesDir s = readFile filePath >>= return . parseMarkdown
+  where filePath = storiesDir </> (storySlug s) `addExtension` ".md"
+        parseMarkdown = readMarkdown def { readerExtensions = multimarkdownExtensions }
+
+storyPandocs :: FilePath -> IO (M.Map Story Pandoc)
+storyPandocs storiesDir = msum' $ zipWith build allStories allPandocActions
+  where msum' = (liftM mconcat) . sequence
+        build s = liftM $ M.singleton s
+        allStories = [minBound..]
+        allPandocActions = (storyPandoc storiesDir) <$> allStories
+
+renderTitle :: Pandoc -> Text
+renderTitle (Pandoc (Meta title _ _) _) = pack $ writePlain def (Pandoc emptyMeta [Plain title])
+  where emptyMeta = Meta mempty mempty mempty