exa/reploy
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

reformat using new hindent (cuteness +63)

Browse source
This commit is contained in:
Mirek Kratochvil 2023-10-16 19:08:27 +02:00
parent 56dcda5619
commit e2cec0c7a7
5 changed files with 235 additions and 194 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
FormatOpts.hs
View file

@ -23,10 +23,10 @@ import Text.Pandoc.Options
markdownReadOpts =
def
{ readerExtensions =
Text.Pandoc.Extensions.extensionsFromList $
Text.Pandoc.Extensions.extensionsToList
Text.Pandoc.Extensions.pandocExtensions ++
[ Text.Pandoc.Extensions.Ext_smart
Text.Pandoc.Extensions.extensionsFromList
$ Text.Pandoc.Extensions.extensionsToList
Text.Pandoc.Extensions.pandocExtensions
++ [ Text.Pandoc.Extensions.Ext_smart
, Ext_lists_without_preceding_blankline
]
}

37
Tags.hs
View file

@ -44,8 +44,10 @@ sourceTagMetaFile fp = do
case yml' of
Left err ->
error
("Failed to load tag metadata from " ++ fp ++ ": " ++
Y.prettyPrintParseException err)
("Failed to load tag metadata from "
++ fp
++ ": "
++ Y.prettyPrintParseException err)
Right yml -> traverse_ go (KM.toList yml)
where go :: (KM.Key, Y.Value) -> Site ()
go (k, v') =
@ -61,8 +63,10 @@ sourceTagMetaFile fp = do
| v == ov = Just ov
| otherwise =
error
("conflicting tag metadata for tag " ++ ks ++ " in " ++
fp)
("conflicting tag metadata for tag "
++ ks
++ " in "
++ fp)
ins Nothing = Just v
in tagMeta %= M.alter ins kx
@ -87,10 +91,11 @@ sourceTags :: Site ()
sourceTags = do
sgat <-
map
(second $ map splitTag .
(^.. pageMeta . key "tags" . values . _String . to T.unpack)) .
M.assocs <$>
use pages
(second
$ map splitTag
. (^.. pageMeta . key "tags" . values . _String . to T.unpack))
. M.assocs
<$> use pages
ehtags .= M.fromList (invExpandTags sgat)
htags .= M.fromList (invTags sgat)
@ -115,14 +120,14 @@ htagRenderMeta makeLink htag = do
links <- map fromString <$> traverse makeLink htags
names <- map fromString <$> traverse getTagGroupName htags
metas <- traverse htagMeta htags
pure $
Y.object
pure
$ Y.object
[ ("href", last links)
, ("name", last names)
, ("meta", last metas)
, ( "htag"
, Y.array $
zipWith3
, Y.array
$ zipWith3
(\l n m -> Y.object [("href", l), ("name", n), ("meta", m)])
links
names
@ -151,8 +156,8 @@ genericTaggedPagesRenderMeta ::
-> M.Map [String] [FilePath]
-> Site Y.Value
genericTaggedPagesRenderMeta makePageMeta htag tagmap =
Y.array . map snd . sortOn (uncurry toSortKey) <$>
traverse metaPair (maybe [] id $ tagmap M.!? htag)
Y.array . map snd . sortOn (uncurry toSortKey)
<$> traverse metaPair (maybe [] id $ tagmap M.!? htag)
where
metaPair x = do
m <- makePageMeta x
@ -190,6 +195,6 @@ htagRenderMetaWithSubtags makeLink extraMeta subtagMeta htag = do
m <- subtagMeta x
pure (joinPath x, m)
subtagMetas <-
Y.array . filter (/= Y.Null) . map snd . sortOn (uncurry toSortKey) <$>
traverse metaPair subtags
Y.array . filter (/= Y.Null) . map snd . sortOn (uncurry toSortKey)
<$> traverse metaPair subtags
pure $ meta `objMerge` Y.object [("subtags", subtagMetas)] `objMerge` em

172
Types.hs
View file

@ -32,19 +32,16 @@ import qualified Text.Mustache as Mu
import qualified Text.Pandoc.Definition
-- | Information about a single deployed page (with metadata etc).
data PageInfo =
PageInfo
data PageInfo = PageInfo
{ _pagePath :: FilePath -- ^ original path to the markdown file
, _pageMeta :: Y.Value -- ^ YAML metadata extracted from the file
, _pageDoc :: Text.Pandoc.Definition.Pandoc -- ^ Page data
}
deriving (Show)
} deriving (Show)
makeLenses ''PageInfo
-- | Complete internal state of the deployment process that holds all data
data SiteState =
SiteState
data SiteState = SiteState
{ _pages :: M.Map FilePath PageInfo -- ^ Map of page mounts to `PageInfo`
, _redirects :: M.Map FilePath FilePath -- ^ Map of redirects (from -> to)
, _htags :: M.Map [String] [FilePath] -- ^ Map of tags, assigning to each tag sequence a list of tagged page mounts
@ -70,8 +67,7 @@ data SiteState =
, _urlBase :: FilePath -- ^ "Root route" to prepend to all absolute links.
, _appendUrlIndex :: Bool -- ^ Append full index filenames to all page URLs
, _dumpFinalState :: Bool -- ^ Triggers printing out the structure when the processing finishes.
}
deriving (Show)
} deriving (Show)
makeLenses ''SiteState
@ -82,98 +78,116 @@ type Site a = StateT SiteState IO a
siteOptions' :: Parser SiteState
siteOptions' = do
_outputDir <-
strOption $
long "output" <>
short 'd' <>
help "Directory to render the site to" <> value "_site" <> showDefault
strOption
$ long "output"
<> short 'd'
<> help "Directory to render the site to"
<> value "_site"
<> showDefault
_searchDataOut <-
Just <$>
(strOption $
long "search-data-output" <>
help "Output JSON with searchable page data to this file") <|>
pure Nothing
Just
<$> (strOption
$ long "search-data-output"
<> help "Output JSON with searchable page data to this file")
<|> pure Nothing
_assetDirs <-
many . strOption $
long "assets" <>
short 'a' <>
help "Assets directory to be copied verbatim (possibly multiple paths)"
many . strOption
$ long "assets"
<> short 'a'
<> help
"Assets directory to be copied verbatim (possibly multiple paths)"
_sourceDirs <-
many . strOption $
long "source-directory" <>
short 's' <>
help "Path to the directory with source data (possibly multiple paths)"
many . strOption
$ long "source-directory"
<> short 's'
<> help
"Path to the directory with source data (possibly multiple paths)"
_notSourceDirs <-
many . strOption $
long "exclude-source-directory" <>
help
many . strOption
$ long "exclude-source-directory"
<> help
"Names of subdirectories of the sources that should never be used for sourcing pages (possibly multiple directory names)"
_tagMetaFile <-
strOption $
long "tag-metadata-file" <>
help "Name of files with tag metadata" <>
value "tag-metadata.yml" <> showDefault
strOption
$ long "tag-metadata-file"
<> help "Name of files with tag metadata"
<> value "tag-metadata.yml"
<> showDefault
_templateDir <-
strOption $
long "template-directory" <>
help "Path to the directory with templates" <>
value "templates" <> showDefault
strOption
$ long "template-directory"
<> help "Path to the directory with templates"
<> value "templates"
<> showDefault
_defaultTemplate <-
strOption $
long "default-template" <>
help "Default template to use for stuff (as found in templates directory)" <>
value "default.html" <> showDefault
strOption
$ long "default-template"
<> help
"Default template to use for stuff (as found in templates directory)"
<> value "default.html"
<> showDefault
_redirectTemplate <-
strOption $
long "redirect-template" <>
help "Template for making redirect pages" <>
value "redirect.html" <> showDefault
strOption
$ long "redirect-template"
<> help "Template for making redirect pages"
<> value "redirect.html"
<> showDefault
_tagTemplate <-
strOption $
long "tag-template" <>
help "Template for making category view pages" <>
value "tag.html" <> showDefault
strOption
$ long "tag-template"
<> help "Template for making category view pages"
<> value "tag.html"
<> showDefault
_listTemplate <-
strOption $
long "list-template" <>
help "Template for making tag-listing pages" <>
value "list.html" <> showDefault
strOption
$ long "list-template"
<> help "Template for making tag-listing pages"
<> value "list.html"
<> showDefault
_metadataSuffix <-
strOption $
long "metadata-suffix" <>
help
"Suffix for YAML files with base metadata for each markdown page. Metadata from files override the extra metadata specified on commandline, but are overridden by metadata specified directly in the markdown header of the pages." <>
value ".metadata.yml" <> showDefault
strOption
$ long "metadata-suffix"
<> help
"Suffix for YAML files with base metadata for each markdown page. Metadata from files override the extra metadata specified on commandline, but are overridden by metadata specified directly in the markdown header of the pages."
<> value ".metadata.yml"
<> showDefault
_extraMeta <-
let processKeyVal :: String -> Y.Value
processKeyVal opt =
case Y.decodeEither' $ Data.ByteString.UTF8.fromString opt of
Right v -> v
Left err ->
error $
"cannot parse YAML in --extra-metadata: " ++
Y.prettyPrintParseException err
in fmap (foldl objMerge Y.Null . map processKeyVal) . many . strOption $
long "extra-metadata" <>
help
error
$ "cannot parse YAML in --extra-metadata: "
++ Y.prettyPrintParseException err
in fmap (foldl objMerge Y.Null . map processKeyVal) . many . strOption
$ long "extra-metadata"
<> help
"Extra metadata to add to pages rendering in YAML format. May be specified multiple times."
_urlBase <-
strOption $
long "url-base" <>
short 'u' <> help "Base absolute URL" <> value "/" <> showDefault
strOption
$ long "url-base"
<> short 'u'
<> help "Base absolute URL"
<> value "/"
<> showDefault
_indexFile <-
strOption $
long "index-filename" <>
help "Base absolute URL" <> value "index.html" <> showDefault
strOption
$ long "index-filename"
<> help "Base absolute URL"
<> value "index.html"
<> showDefault
_appendUrlIndex <-
switch $
long "append-url-index" <>
help
switch
$ long "append-url-index"
<> help
"Append 'index.html' to all urls, negating server problems with directory index settings."
_dumpFinalState <-
switch $
long "dump-state" <>
short 'D' <>
help "Print out the complete internal state after the site is built"
switch
$ long "dump-state"
<> short 'D'
<> help
"Print out the complete internal state after the site is built"
pure
SiteState
{ _pages = M.empty
@ -191,6 +205,6 @@ siteOptions' = do
siteOptions =
info
(siteOptions' <**> helper)
(fullDesc <>
progDesc "Build a R3 static site" <>
header "reploy - the R3 static site builder")
(fullDesc
<> progDesc "Build a R3 static site"
<> header "reploy - the R3 static site builder")

12
Utils.hs
View file

@ -75,8 +75,12 @@ addHeadingLinks cls = Text.Pandoc.Walk.walk go
Header
lvl
attr
(inlines ++
[Link ("", [cls], []) [Str "#"] ("#" <> id, "Link to this section")])
(inlines
++ [ Link
("", [cls], [])
[Str "#"]
("#" <> id, "Link to this section")
])
go x = x
-- | @"https://example.com" `hasUriScheme` "https"@
@ -132,8 +136,8 @@ sourcePaths fp process = do
| null ds = False
| last ds `elem` notSource = True
| otherwise = False
io (getRecursiveContents (pure . ignoreDir . splitDirectories) fp) >>=
foldMapM process
io (getRecursiveContents (pure . ignoreDir . splitDirectories) fp)
>>= foldMapM process
-- | Given a path to a file, try to make the path writable by making all
-- directories on the path. (Interned from Hakyll.)

98
reploy.hs
View file

@ -81,8 +81,8 @@ loadPage fp = do
io $ putStrLn $ "P <- " ++ fp
txt <- io $ TIO.readFile fp
{- tear out the metadata manually -}
(T.take 4 txt == "---\n") `unless`
error ("metadata block start missing in " ++ fp)
(T.take 4 txt == "---\n")
`unless` error ("metadata block start missing in " ++ fp)
let (meta, markdown) = T.breakOn "\n---\n" (T.drop 4 txt)
T.null meta `when` error ("metadata block bad in " ++ fp)
{- parse everything -}
@ -90,17 +90,16 @@ loadPage fp = do
md <- io $ runIOorExplode $ readMarkdown markdownReadOpts (T.drop 5 markdown)
{- find the main mount point for the page -}
let mount =
unAbsolute . T.unpack . just ("mount point of " ++ fp) $ yml ^?
key "mount" .
_String
unAbsolute . T.unpack . just ("mount point of " ++ fp)
$ yml ^? key "mount" . _String
existing <- use $ pages . to (M.!? mount)
case existing of
Just pi ->
error $ "mount for " ++ fp ++ " already exists from " ++ _pagePath pi
_ -> pure ()
{- save to the state -}
pages %=
M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pageDoc = md}
pages
%= M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pageDoc = md}
-- | Find which template to use for rendering a page.
pageTemplate :: PageInfo -> Site FilePath
@ -114,8 +113,8 @@ pageTemplates = do
rt <- use redirectTemplate
tt <- use tagTemplate
lt <- use listTemplate
nub . ([rt, tt, lt] ++) <$>
(gets (^.. pages . traverse) >>= traverse pageTemplate)
nub . ([rt, tt, lt] ++)
<$> (gets (^.. pages . traverse) >>= traverse pageTemplate)
-- | Compile a single template in a directory
compileTemplate ::
@ -180,8 +179,8 @@ rootedLink = (<*>) rootedLink' . pure
-- | Process a single link pointing out from a page.
processLink :: FilePath -> FilePath -> Site String
processLink base l =
if any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"] || take 1 l ==
"#"
if any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"]
|| take 1 l == "#"
then pure l
else if isAbsolute l
then rootedPageLink l
@ -203,8 +202,9 @@ addGlobalMeta meta = do
rtp <- rootedPageLink'
Y.Object m <- (`objMerge` meta) <$> use extraMeta
let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m
pure . Mu.object $ l ++
[ ("root", Mu.toMustache $ T.pack r)
pure . Mu.object
$ l
++ [ ("root", Mu.toMustache $ T.pack r)
, ("rawRootUrl", Mu.overText $ T.pack . rt . T.unpack)
, ("pageLink", Mu.overText $ T.pack . rtp . T.unpack)
]
@ -226,8 +226,11 @@ addExtraMeta pi m = do
em' <- io $ Y.decodeFileEither metaPath
case em' of
Left pe ->
error $ "decoding " ++ metaPath ++ " failed: " ++
Y.prettyPrintParseException pe
error
$ "decoding "
++ metaPath
++ " failed: "
++ Y.prettyPrintParseException pe
Right em -> pure $ objMerge em m
else pure m
@ -237,11 +240,13 @@ addExtraMeta pi m = do
addPageMeta :: PageInfo -> Y.Value -> Site Y.Value
addPageMeta pi (Y.Object m) = do
htagMeta <-
traverse (htagRenderMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
values .
_String .
to T.unpack .
to splitTag
traverse (htagRenderMeta tagLink) . sort
$ pi ^.. pageMeta
. key "tags"
. values
. _String
. to T.unpack
. to splitTag
addExtraMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m
-- | If viable for a page (by config), add the TOC field
@ -249,12 +254,16 @@ addTOC :: PageInfo -> Text.Pandoc.Definition.Pandoc -> Y.Value -> Site Y.Value
addTOC pi doc meta@(Y.Object meta') =
let go n = do
toc <-
io . runIOorExplode $ writeHtml5String htmlWriteOpts $
withPandocBlocks (pure . toTableOfContents (tocWriteOpts n)) doc
io . runIOorExplode
$ writeHtml5String htmlWriteOpts
$ withPandocBlocks (pure . toTableOfContents (tocWriteOpts n)) doc
pure . Y.Object $ KM.insert "toc" (Y.String toc) meta'
in case ( pi ^? pageMeta . key "toc" . _Bool
, join $ pi ^? pageMeta . key "toc" . _Number .
to Data.Scientific.toBoundedInteger) of
, join
$ pi ^? pageMeta
. key "toc"
. _Number
. to Data.Scientific.toBoundedInteger) of
(Just False, _) -> pure meta
(_, Nothing) -> go (3 :: Int)
(_, Just n) -> go n
@ -269,8 +278,9 @@ installPage mount pi = do
walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
checkTarget file
body <-
io . runIOorExplode $ writeHtml5String htmlWriteOpts $
addHeadingLinks "header-local-anchor" fixedUrlDoc
io . runIOorExplode
$ writeHtml5String htmlWriteOpts
$ addHeadingLinks "header-local-anchor" fixedUrlDoc
let Y.Object meta' = pi ^. pageMeta
meta = Y.Object $ KM.insert "body" (Y.String body) meta'
meta <- addTOC pi fixedUrlDoc meta >>= addPageMeta pi >>= addGlobalMeta
@ -292,8 +302,8 @@ installRedirect target' from = do
putStrLn $ "@ -> " ++ file ++ " -> " ++ target
makeDirectories file
txt <-
checkedSubstitute templ $
Mu.object [("target", Mu.toMustache $ T.pack target)]
checkedSubstitute templ
$ Mu.object [("target", Mu.toMustache $ T.pack target)]
TIO.writeFile file txt
-- | Install all redirects required by one page.
@ -347,8 +357,8 @@ installAsset ad fp = do
-- | Copy all files from a given asset directory.
installAssetDir :: FilePath -> Site ()
installAssetDir ad =
io (getRecursiveContents (pure . const False) ad) >>=
traverse_ (installAsset ad)
io (getRecursiveContents (pure . const False) ad)
>>= traverse_ (installAsset ad)
-- | Copy all files from the asset directories.
installAssets :: Site ()
@ -375,8 +385,8 @@ makePageLinkRenderMeta :: FilePath -> Site Y.Value
makePageLinkRenderMeta mount = do
link <- rootedPageLink mount
meta <- use $ pages . to (M.! mount) . pageMeta
pure $
Y.object
pure
$ Y.object
[("mount", fromString mount), ("href", fromString link), ("meta", meta)]
wrapPagesMeta :: Y.Value -> String -> FilePath -> Y.Value
@ -424,15 +434,23 @@ renderListing templName fileName makeMeta mark htag = do
renderTags = do
lt <- use tagTemplate
M.keys <$> use ehtags >>=
traverse_
(renderListing lt tagFilename (makeTagRenderMeta >=> addGlobalMeta) "#")
M.keys <$> use ehtags
>>= traverse_
(renderListing
lt
tagFilename
(makeTagRenderMeta >=> addGlobalMeta)
"#")
renderLists = do
lt <- use listTemplate
M.keys <$> use ehtags >>=
traverse_
(renderListing lt listFilename (makeListRenderMeta >=> addGlobalMeta) "*")
M.keys <$> use ehtags
>>= traverse_
(renderListing
lt
listFilename
(makeListRenderMeta >=> addGlobalMeta)
"*")
-- | Transform one mounted PageInfo to the base search data
makeSearchData :: FilePath -> PageInfo -> Site [Y.Value]
@ -447,8 +465,8 @@ makeSearchData mount pi = do
let tagarray = Y.array . map (Y.array . map fromString) $ tagnames
if pi ^? pageMeta . key "search" . _Bool == Just False -- `off` gets parsed as bool
then pure []
else pure $
[ Y.object
else pure
$ [ Y.object
[ ("link", fromString link)
, ("name", maybe (fromString mount) Y.String name)
, ("tags", tagarray)