diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Hakyll/Commands.hs | 5 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules.hs | 13 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 9 | ||||
| -rw-r--r-- | src/Hakyll/Preview/Poll.hs | 56 | ||||
| -rw-r--r-- | src/Hakyll/Web/Html.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Web/Tags.hs | 119 |
6 files changed, 156 insertions, 48 deletions
diff --git a/src/Hakyll/Commands.hs b/src/Hakyll/Commands.hs index 700dda5..6d6b0ae 100644 --- a/src/Hakyll/Commands.hs +++ b/src/Hakyll/Commands.hs @@ -21,6 +21,7 @@ import qualified Hakyll.Check as Check import Hakyll.Core.Configuration import Hakyll.Core.Logger (Verbosity) import Hakyll.Core.Rules +import Hakyll.Core.Rules.Internal import Hakyll.Core.Runtime import Hakyll.Core.Util.File @@ -68,8 +69,8 @@ preview conf verbosity rules port = do server conf port where update = do - _ <- run conf verbosity rules - return () + (_, ruleSet) <- run conf verbosity rules + return $ rulesPattern ruleSet #else preview _ _ _ _ = previewServerDisabled #endif diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 66210b6..c248a9b 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -63,20 +63,26 @@ import Hakyll.Core.Writable -------------------------------------------------------------------------------- -- | Add a route tellRoute :: Routes -> Rules () -tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty +tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty mempty -------------------------------------------------------------------------------- -- | Add a number of compilers tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules () -tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty +tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty -------------------------------------------------------------------------------- -- | Add resources tellResources :: [Identifier] -> Rules () tellResources resources' = Rules $ tell $ - RuleSet mempty mempty $ S.fromList resources' + RuleSet mempty mempty (S.fromList resources') mempty + + +-------------------------------------------------------------------------------- +-- | Add a pattern +tellPattern :: Pattern -> Rules () +tellPattern pattern = Rules $ tell $ RuleSet mempty mempty mempty pattern -------------------------------------------------------------------------------- @@ -116,6 +122,7 @@ flush = Rules $ do -------------------------------------------------------------------------------- match :: Pattern -> Rules () -> Rules () match pattern rules = do + tellPattern pattern flush ids <- getMatches pattern tellResources ids diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 6bb82df..a7c2059 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -47,14 +47,17 @@ data RuleSet = RuleSet rulesCompilers :: [(Identifier, Compiler SomeItem)] , -- | A set of the actually used files rulesResources :: Set Identifier + , -- | A pattern we can use to check if a file *would* be used. This is + -- needed for the preview server. + rulesPattern :: Pattern } -------------------------------------------------------------------------------- instance Monoid RuleSet where - mempty = RuleSet mempty mempty mempty - mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) = - RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) + mempty = RuleSet mempty mempty mempty mempty + mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) = + RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2) -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs index 36b057e..7dd266b 100644 --- a/src/Hakyll/Preview/Poll.hs +++ b/src/Hakyll/Preview/Poll.hs @@ -1,40 +1,64 @@ +-------------------------------------------------------------------------------- module Hakyll.Preview.Poll ( watchUpdates ) where + -------------------------------------------------------------------------------- -import Filesystem.Path.CurrentOS (decodeString, encodeString) -import System.FSNotify (startManagerConf, watchTree, - Event(..), WatchConfig(..)) +import Control.Concurrent.MVar (newMVar, putMVar, takeMVar) +import Control.Monad (when) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import System.Directory (canonicalizePath) +import System.FilePath (pathSeparators) +import System.FSNotify (Event (..), WatchConfig (..), + startManagerConf, watchTree) + -------------------------------------------------------------------------------- import Hakyll.Core.Configuration - +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern -------------------------------------------------------------------------------- -- | A thread that watches for updates in a 'providerDirectory' and recompiles -- a site as soon as any changes occur -watchUpdates :: Configuration -> IO () -> IO () +watchUpdates :: Configuration -> IO Pattern -> IO () watchUpdates conf update = do - _ <- update - manager <- startManagerConf (Debounce 0.1) - watchTree manager path (not . isRemove) update' - where - path = decodeString $ providerDirectory conf - update' evt = do - ignore <- shouldIgnoreFile conf $ eventPath evt - if ignore then return () else update + let providerDir = decodeString $ providerDirectory conf + lock <- newMVar () + pattern <- update + fullProviderDir <- canonicalizePath $ providerDirectory conf + manager <- startManagerConf (Debounce 0.1) + let allowed event = do + -- Absolute path of the changed file. This must be inside provider + -- dir, since that's the only dir we're watching. + let path = eventPath event + relative = dropWhile (`elem` pathSeparators) $ + drop (length fullProviderDir) path + identifier = fromFilePath relative + shouldIgnore <- shouldIgnoreFile conf path + return $ not shouldIgnore && matches pattern identifier + + watchTree manager providerDir (not . isRemove) $ \event -> do + () <- takeMVar lock + allowed' <- allowed event + when allowed' $ update >> return () + putMVar lock () + + +-------------------------------------------------------------------------------- eventPath :: Event -> FilePath eventPath evt = encodeString $ evtPath evt where - evtPath (Added p _) = p + evtPath (Added p _) = p evtPath (Modified p _) = p - evtPath (Removed p _) = p + evtPath (Removed p _) = p +-------------------------------------------------------------------------------- isRemove :: Event -> Bool isRemove (Removed _ _) = True -isRemove _ = False +isRemove _ = False diff --git a/src/Hakyll/Web/Html.hs b/src/Hakyll/Web/Html.hs index 37e517d..58b5c43 100644 --- a/src/Hakyll/Web/Html.hs +++ b/src/Hakyll/Web/Html.hs @@ -54,7 +54,7 @@ demoteHeaders = withTags $ \tag -> case tag of -------------------------------------------------------------------------------- isUrlAttribute :: String -> Bool -isUrlAttribute = (`elem` ["src", "href"]) +isUrlAttribute = (`elem` ["src", "href", "data"]) -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs index fe99e3c..0bca696 100644 --- a/src/Hakyll/Web/Tags.hs +++ b/src/Hakyll/Web/Tags.hs @@ -49,8 +49,12 @@ module Hakyll.Web.Tags , tagsRules , renderTags , renderTagCloud + , renderTagCloudWith + , tagCloudField + , tagCloudFieldWith , renderTagList , tagsField + , tagsFieldWith , categoryField , sortTagsBy , caseInsensitiveTags @@ -184,7 +188,6 @@ renderTags makeHtml concatHtml tags = do -------------------------------------------------------------------------------- -- | Render a tag cloud in HTML --- TODO: Maybe produce a Context here renderTagCloud :: Double -- ^ Smallest font size, in percent -> Double @@ -193,19 +196,75 @@ renderTagCloud :: Double -- ^ Input tags -> Compiler String -- ^ Rendered cloud -renderTagCloud minSize maxSize = renderTags makeLink (intercalate " ") +renderTagCloud = renderTagCloudWith makeLink (intercalate " ") where - makeLink tag url count min' max' = renderHtml $ + makeLink minSize maxSize tag url count min' max' = renderHtml $ H.a ! A.style (toValue $ "font-size: " ++ size count min' max') ! A.href (toValue url) $ toHtml tag + where + -- Show the relative size of one 'count' in percent + size count min' max' = + let diff = 1 + fromIntegral max' - fromIntegral min' + relative = (fromIntegral count - fromIntegral min') / diff + size' = floor $ minSize + relative * (maxSize - minSize) + in show (size' :: Int) ++ "%" + + +-------------------------------------------------------------------------------- +-- | Render a tag cloud in HTML +renderTagCloudWith :: (Double -> Double -> + String -> String -> Int -> Int -> Int -> String) + -- ^ Render a single tag link + -> ([String] -> String) + -- ^ Concatenate links + -> Double + -- ^ Smallest font size, in percent + -> Double + -- ^ Biggest font size, in percent + -> Tags + -- ^ Input tags + -> Compiler String + -- ^ Rendered cloud +renderTagCloudWith makeLink cat minSize maxSize = + renderTags (makeLink minSize maxSize) cat + + +-------------------------------------------------------------------------------- +-- | Render a tag cloud in HTML as a context +tagCloudField :: String + -- ^ Destination key + -> Double + -- ^ Smallest font size, in percent + -> Double + -- ^ Biggest font size, in percent + -> Tags + -- ^ Input tags + -> Context a + -- ^ Context +tagCloudField key minSize maxSize tags = + field key $ \_ -> renderTagCloud minSize maxSize tags + - -- Show the relative size of one 'count' in percent - size count min' max' = - let diff = 1 + fromIntegral max' - fromIntegral min' - relative = (fromIntegral count - fromIntegral min') / diff - size' = floor $ minSize + relative * (maxSize - minSize) - in show (size' :: Int) ++ "%" +-------------------------------------------------------------------------------- +-- | Render a tag cloud in HTML as a context +tagCloudFieldWith :: String + -- ^ Destination key + -> (Double -> Double -> + String -> String -> Int -> Int -> Int -> String) + -- ^ Render a single tag link + -> ([String] -> String) + -- ^ Concatenate links + -> Double + -- ^ Smallest font size, in percent + -> Double + -- ^ Biggest font size, in percent + -> Tags + -- ^ Input tags + -> Context a + -- ^ Context +tagCloudFieldWith key makeLink cat minSize maxSize tags = + field key $ \_ -> renderTagCloudWith makeLink cat minSize maxSize tags -------------------------------------------------------------------------------- @@ -219,23 +278,27 @@ renderTagList = renderTags makeLink (intercalate ", ") -------------------------------------------------------------------------------- --- | Render tags with links with custom function to get tags -tagsFieldWith :: (Identifier -> Compiler [String]) -- ^ Get the tags - -> String -- ^ Destination field - -> Tags -- ^ Tags structure - -> Context a -- ^ Resulting context -tagsFieldWith getTags' key tags = field key $ \item -> do +-- | Render tags with links with custom functions to get tags and to +-- render links +tagsFieldWith :: (Identifier -> Compiler [String]) + -- ^ Get the tags + -> (String -> (Maybe FilePath) -> Maybe H.Html) + -- ^ Render link for one tag + -> ([H.Html] -> H.Html) + -- ^ Concatenate tag links + -> String + -- ^ Destination field + -> Tags + -- ^ Tags structure + -> Context a + -- ^ Resulting context +tagsFieldWith getTags' renderLink cat key tags = field key $ \item -> do tags' <- getTags' $ itemIdentifier item links <- forM tags' $ \tag -> do route' <- getRoute $ tagsMakeId tags tag return $ renderLink tag route' - return $ renderHtml $ mconcat $ intersperse ", " $ catMaybes $ links - where - -- Render one tag link - renderLink _ Nothing = Nothing - renderLink tag (Just filePath) = Just $ - H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag + return $ renderHtml $ cat $ catMaybes $ links -------------------------------------------------------------------------------- @@ -243,7 +306,8 @@ tagsFieldWith getTags' key tags = field key $ \item -> do tagsField :: String -- ^ Destination key -> Tags -- ^ Tags -> Context a -- ^ Context -tagsField = tagsFieldWith getTags +tagsField = + tagsFieldWith getTags simpleRenderLink (mconcat . intersperse ", ") -------------------------------------------------------------------------------- @@ -251,7 +315,16 @@ tagsField = tagsFieldWith getTags categoryField :: String -- ^ Destination key -> Tags -- ^ Tags -> Context a -- ^ Context -categoryField = tagsFieldWith getCategory +categoryField = + tagsFieldWith getCategory simpleRenderLink (mconcat . intersperse ", ") + + +-------------------------------------------------------------------------------- +-- | Render one tag link +simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html +simpleRenderLink _ Nothing = Nothing +simpleRenderLink tag (Just filePath) = + Just $ H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag -------------------------------------------------------------------------------- |