Read More...\n"] + --read_more = concat ["
Read More...\n"] + +contentsLink :: Text -> Text +contentsLink fp = T.concat ["
tag +-- and append the 'Read More...' link. +getPreview :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp +getPreview qhr set fp = do +-- #ifdef GHC_7_4 +-- qAddDependentFile fp +-- #endif + contents <- fmap T.unpack $ runIO $ TI.readFile fp + -- hear we can truncate the contents + let split_contents = splitOn "
" $ pack contents + let take_n = if Prelude.length split_contents > 3 then 3 else Prelude.length split_contents + let preview = intercalate "
" $ take take_n split_contents
+ let read_more = readMore $ pack fp
+ let contents_link = contentsLink $ pack fp
+ hamletFromString qhr set $ unpack $ intercalate "\n" [contents_link, preview, read_more]
+
+
+makePreviews :: Q Exp
+makePreviews = makePreviewsWithOptions "templates/articles"
+
+-- | This can be used to make the previews for all the articles
+-- It fetches the articles to display, and for each one calls our modified
+-- hamletFileWithSettings (getPreview)
+makePreviewsWithOptions :: Text -> Q Exp
+makePreviewsWithOptions path =
+ do
+ articles <- runIO $ getArticleNames path
+ xs <- mapM (\x -> getPreview rules NP.defaultHamletSettings $ unpack x) articles
+ return $ DoE (map NoBindS xs)
+
+
+-- | Given a stripped article names (eg 'civ6', 'foo'), makeGet
+-- will create the functions which 'gets' that article. It names the function
+-- by prefixing the article name with 'get' and suffixing with 'R' (eg 'foo' -> 'getfooR')
+-- The function returned calls defaultLayout, sets the title based on the
+-- given prefix and the article name, and calls widgetFile on the article.
+-- The function returned effectively does:
+-- defaultLayout $ do {
+-- $(setTitle prefix ++ article_name)
+-- $(widgetFile articles/article_name)}
+makeGet :: Text -> Text -> Q Exp -> Text -> Q Dec
+makeGet prefix path exp article_name =
+ let article_name' = unpack article_name
+ prefix' = unpack prefix
+ fname = mkName $ concat ["get", article_name', "R"]
+ in
+ do {
+ dl <- exp;
+ widget <- whamletFile $ joinPath [unpack path, addExtension article_name' ".hamlet"];
+ --dl <- [e|defaultLayout|];
+ title <- runIO $ getTitle (pack $ joinPath [unpack path, addExtension article_name' ".hamlet"]);
+ set_title <- [e| setTitle $ toHtml (prefix' ++ " " ++ (unpack title)) |];
+ --decs <- makeGet rest;
+ return (ValD (VarP fname)
+ (NormalB (AppE dl {-(VarE (mkName "defaultLayout"))-} (ParensE
+ (DoE [NoBindS set_title,
+ NoBindS widget])))) []);
+ }
+
+
+makeGets :: Q [Dec]
+makeGets = makeGetsWithOptions "" "templates/articles/" (return (VarE (mkName "defaultLayout"))) -- maybe change this
+
+-- arg example
+-- makeGetsWithOptions prefix "Matt Eads:"
+-- path "templates/articles/" -- make sure we add a / to the end if needed
+-- exp [e|\x -> do defaultLayout $ x|] -- not sure what the default should be here
+--
+
+-- | Gets the list of articles in templates/articles, makes all
+-- the 'getter' functions for the articles (see makeGet), and creates
+-- the 'getArticleR' function (see makeGetArticle).
+makeGetsWithOptions :: Text -> Text -> Q Exp -> Q [Dec]
+makeGetsWithOptions prefix path exp =
+ do
+ articles <- runIO $ getArticleNames path
+ let articles' = map stripName articles
+ decs <- mapM (makeGet prefix path exp) articles'
+ getArticle <- makeGetArticle articles'
+ return (decs ++ getArticle)
+
+-- | Given a list of articles, returns the 'getArticleR' function.
+-- The function returned will take the article_name as an arg, and
+-- defer to the appropriate get , , etc.)
+getHeader :: Text -> Text
+getHeader contents =
+ let rgx = mkRegexWithOpts "(.*)<[a-zA-Z]" False True
+ in case matchRegex rgx $ unpack contents of
+ (Just matches) -> pack $ head matches
+ Nothing -> ""
+
+-- | Given a file path, returns the page title for the article.
+-- The title should be a html comment () and occur before
+-- any other text, other than the date comment. The date and title can
+-- be put in either order. If no title can be found, the stripped file
+-- path is used.
+getTitle :: Text -> IO Text
+getTitle fp =
+ do
+ contents <- TI.readFile $ unpack fp
+ return $
+ let header = getHeader contents
+ rgx = mkRegexWithOpts "" False True
+ non_match = case matchRegexAll rgx $ unpack header of
+ Nothing -> ""
+ Just (before, _, after, _) -> concat [before, after]
+ rgx2 = mkRegexWithOpts "" False True
+ in case matchRegex rgx2 non_match of
+ (Just matches) -> pack $ head matches
+ Nothing -> stripName fp
+
+
+makeContentsEntry :: (Text, Text) -> Text
+makeContentsEntry (id, title) = T.concat ["
"] ++ entries)
+ return $ DoE [NoBindS ham]
+
diff --git a/test/main.hs b/test/main.hs
new file mode 100644
--- /dev/null
+++ b/test/main.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+import Test.Hspec
+import Data.Text
+import Yesod hiding (get)
+import Yesod.Articles
+import Yesod.Test
+import Handlers
+
+
+spec :: Spec
+spec = yesodSpec (ArticlesTestApp) $ do
+ ydescribe "Basic test" $ do
+ yit "Get homepage with previews and contents" $ do
+ get ("/" :: Text)
+ statusIs 200
+ -- printBody
+ bodyContains "Test paragraph 1.1"
+ bodyNotContains "Test paragraph 1.5"
+ bodyContains "Read More..."
+ bodyContains "