From: Cameron Ball Date: Mon, 18 Feb 2019 10:28:43 +0000 (+0800) Subject: Learn to initialise projects with configurable themes X-Git-Url: http://cameron1729.xyz/?p=xyz.git;a=commitdiff_plain;h=f0dde0943c6d9bbd70e7c950aa5fa38276ee43d1 Learn to initialise projects with configurable themes --- diff --git a/app/Main.hs b/app/Main.hs index 21dfb7e..742b739 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,29 +7,41 @@ import System.Directory import Prelude hiding (init) import Data.List (intercalate) import Text.JSON +import Text.JSON.Generic import Data.Text hiding (intercalate, unlines, init) - -data Project = Project { - name :: Text, - description :: Text - } deriving (Show) +import System.File.Tree hiding (mapM, mapM_) +import System.Directory (doesFileExist) main :: IO () main = getArgs >>= parse init :: IO () init = do - dirExists <- doesDirectoryExist "entries" + dirExists <- doesFileExist "xyz.json" if dirExists then putStrLn "Project already initialised" else do createDirectory "entries" + home <- getHomeDirectory + templates <- allFilesIn $ home ++ "/.xyz/themes" putStrLn "Enter a name for your project:" projectName <- getLine putStrLn "Enter short description for your project:" projectDescription <- getLine - writeFile "xyz.json" . encode . toJSObject $ [("name", projectName), ("description", projectDescription), ("theme", "xyz")] + putStrLn $ "Which theme would you like to use?\n\n" ++ (ununlines templates) + theme <- getLine + writeFile "xyz.json" . encode . toJSObject $ [("name", projectName), ("description", projectDescription), ("theme", theme)] putStrLn "Initialised empty project" +build :: IO () +build = do + fileExists <- doesFileExist "xyz.json" + if fileExists + then do + files <- allFilesIn "entries" + home <- getHomeDirectory + config <- readFile "xyz.json" + someFunc (decodeJSON config :: ProjectConfig) files >> putStrLn "Build successful" + else putStrLn "This does not appear to be a valid project directory" ununlines :: [String] -> String ununlines = intercalate "\n\n" @@ -44,7 +56,7 @@ usage = putStr . ununlines $ [ ] parse ["init"] = init >> exit -parse ["build"] = someFunc >> exit +parse ["build"] = build >> exit parse [_] = usage >> exit parse [] = usage >> exit diff --git a/entries/.gitignore b/entries/.gitignore deleted file mode 100644 index e69de29..0000000 diff --git a/package.yaml b/package.yaml index 4fca695..966395a 100644 --- a/package.yaml +++ b/package.yaml @@ -26,6 +26,7 @@ dependencies: - filepath - template - json +- filesystem-trees library: source-dirs: src diff --git a/src/Lib.hs b/src/Lib.hs index 1954a89..1ba6286 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} module Lib - ( someFunc + ( someFunc, EntryList, allFilesIn, ProjectConfig ) where import Data.Function (on) @@ -17,7 +19,27 @@ import Data.Time.Format import Data.Time.LocalTime import Prelude hiding (lines) import System.Directory -import System.FilePath.Posix (takeBaseName) +import System.FilePath.Posix (takeBaseName, takeDirectory) +import Data.Data +import Data.Typeable + +data Theme = Theme { + name :: String, -- works better with getHomeDirectory + templates :: [(String, Template)] + } deriving (Show) + +data ProjectConfig = ProjectConfig { + name :: Text, + description :: Text, + theme :: String -- as above + } deriving (Show, Data, Typeable) + +data Project = Project { + name :: Text, + description :: Text, + theme :: Theme, + entries :: EntryList + } deriving (Show) data BlogEntry = BlogEntry { postDate :: UTCTime, @@ -43,13 +65,34 @@ stampsToEntryList stamps = map (\(a,b) -> (a, reverse $ map (\(c,d) -> (c, rever foldl (\c -> \v -> c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps -entryListToPaths :: EntryList -> [Text] -entryListToPaths el = concat $ concat $ map (\(year, months) +getEntriesTemplate :: Project -> Template +getEntriesTemplate p = case lookup "entry.html" $ templates $ theme (p :: Project) of + Just a -> a + +getEntriesVideoTemplate :: Project -> Template +getEntriesVideoTemplate p = case lookup "entry-video.html" $ templates $ theme (p :: Project) of + Just a -> a + +getTemplateForEntry :: Project -> BlogEntry -> Template +getTemplateForEntry p e = case video e of + Just _ -> getEntriesVideoTemplate p + Nothing -> getEntriesTemplate p + +getIndexTemplate :: Project -> Template +getIndexTemplate p = case lookup "index.html" $ templates $ theme (p :: Project) of + Just a -> a + +getEntryPages :: Project -> [(Text, Text)] +getEntryPages p = concat $ concat $ map (\(year, months) -> map (\(month, entries) -> map (\(entryNum, entry) -> - year `append` - "/" `append` - month) entries) months) el + (intercalate "/" [ + "build", + format (postDate entry) "%Y", + format (postDate entry) "%B", + urlify (title entry) `append` ".html"], + entryToMarkup entry (getTemplateForEntry p entry)) + ) entries) months) (entries p) entryListToIndex :: EntryList -> Text entryListToIndex el = unorderedList Nothing $ map (\(year, monthList) -> unorderedList (Just year) $ map (\(month, entryList) -> unorderedList (Just month) $ map (\x -> " year <> "/" <> month <> "/" <> ((urlify . title . snd) x) <> ".html\">" <> (title . snd) x <> "") entryList) monthList) el @@ -87,39 +130,25 @@ rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (u meta = splitOn "::" (fileLines !! 0) fileLines = lines rawEntry -allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(filter(/= ".gitignore"))<$>(getDirectoryContents dir) - -exportEntry entry = do - rawTemplateNormal <- readFile "templates/entry.html" - rawTemplateVideo <- readFile "templates/entry-video.html" - - let entryTemplate = template . pack $ case (video entry) of - Nothing -> rawTemplateNormal - Just a -> rawTemplateVideo +allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(getDirectoryContents dir) - writeFile (unpack $ intercalate "/" [ - "build", - format (postDate entry) "%Y", - format (postDate entry) "%B", - urlify (title entry) `append` ".html"]) $ unpack $ entryToMarkup entry entryTemplate - -exportIndex :: EntryList -> IO() -exportIndex entryList = do - rawTemplate <- readFile "templates/index.html" - - let indexTemplate = template . pack $ rawTemplate - let indexContext = context [("index", entryListToIndex entryList)] - - writeFile "build/index.html" $ unpack $ toStrict $ render indexTemplate indexContext - -someFunc = do +someFunc projectConfig files = do files <- fmap (reverse . sort) $ allFilesIn "entries" rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries - entryPaths <- return $ entryListToPaths $ stampsToEntryList entryList - mapM_ (createDirectoryIfMissing True . ("build/" ++) . unpack) entryPaths - mapM_ exportEntry entryList - exportIndex $ stampsToEntryList entryList + homeDir <- getHomeDirectory + + let themeName = theme (projectConfig :: ProjectConfig) + themeTemplatePaths <- allFilesIn $ homeDir ++ "/.xyz/themes/" ++ themeName + themeTemplates <- mapM (\x -> (readFile $ homeDir ++ "/.xyz/themes/" ++ themeName ++ "/" ++ x) >>= (\y -> return (x, (template . fromString) y))) themeTemplatePaths + + let projectName = name (projectConfig :: ProjectConfig) + let projectDescription = description (projectConfig :: ProjectConfig) + let project = Project projectName projectDescription (Theme themeName themeTemplates) (stampsToEntryList entryList) + + mapM_ (createDirectoryIfMissing True . takeDirectory . unpack . fst) $ getEntryPages project + mapM_ (\x -> writeFile (unpack $ fst x) (unpack $ snd x)) $ getEntryPages project + writeFile "build/index.html" $ unpack $ toStrict $ render (getIndexTemplate project) $ context [("index", entryListToIndex (entries project))] context :: [(Text, Text)] -> Context context assocs x = case lookup x $ assocs of diff --git a/stack.yaml b/stack.yaml index aa814d3..105c625 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,5 +2,8 @@ flags: {} packages: - . extra-deps: +- data-lens-2.11.2 +- filesystem-trees-0.0 - template-0.2.0.10 -resolver: lts-12.9 +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/9.yaml diff --git a/templates/entry-video.html b/templates/entry-video.html deleted file mode 100644 index 517aa37..0000000 --- a/templates/entry-video.html +++ /dev/null @@ -1,62 +0,0 @@ - - - - - blog@cameron1729 - $title - - - - -
-

$title

-

$date (blog index)

- $body -

ᚳᚱᛒ

- - - diff --git a/templates/entry.html b/templates/entry.html deleted file mode 100644 index 8f5b378..0000000 --- a/templates/entry.html +++ /dev/null @@ -1,51 +0,0 @@ - - - - - blog@cameron1729 - $title - - - - -

$title

-

$date (blog index)

- $body -

ᚳᚱᛒ

- - - diff --git a/templates/index.html b/templates/index.html deleted file mode 100644 index 6a9d20c..0000000 --- a/templates/index.html +++ /dev/null @@ -1,31 +0,0 @@ - - - - - blog@cameron1729 - - - - $index - - -