From 92b54f707e491f2569fd9fa49c015a59c7067822 Mon Sep 17 00:00:00 2001 From: Pedro Correa Date: Mon, 26 Jun 2023 18:02:31 -0300 Subject: [PATCH] :sparkles: creating package for Haskell blog --- Haskell/blog/LICENSE.txt | 29 +++++ Haskell/blog/Main.hs | 16 --- Haskell/blog/README.org | 5 + Haskell/blog/app/Main.hs | 50 ++++++++ Haskell/blog/app/OptParse.hs | 109 ++++++++++++++++++ Haskell/blog/hs-blog.cabal | 53 +++++++++ Haskell/blog/package.yaml | 6 - Haskell/blog/src/HsBlog.hs | 23 ++++ Haskell/blog/src/HsBlog/Convert.hs | 20 ++++ Haskell/blog/{ => src/HsBlog}/Html.hs | 9 +- .../blog/{ => src/HsBlog}/Html/Internal.hs | 18 ++- Haskell/blog/{ => src/HsBlog}/Markup.hs | 3 +- 12 files changed, 315 insertions(+), 26 deletions(-) create mode 100644 Haskell/blog/LICENSE.txt delete mode 100644 Haskell/blog/Main.hs create mode 100644 Haskell/blog/README.org create mode 100644 Haskell/blog/app/Main.hs create mode 100644 Haskell/blog/app/OptParse.hs create mode 100644 Haskell/blog/hs-blog.cabal delete mode 100644 Haskell/blog/package.yaml create mode 100644 Haskell/blog/src/HsBlog.hs create mode 100644 Haskell/blog/src/HsBlog/Convert.hs rename Haskell/blog/{ => src/HsBlog}/Html.hs (55%) rename Haskell/blog/{ => src/HsBlog}/Html/Internal.hs (82%) rename Haskell/blog/{ => src/HsBlog}/Markup.hs (98%) diff --git a/Haskell/blog/LICENSE.txt b/Haskell/blog/LICENSE.txt new file mode 100644 index 0000000..f12e08e --- /dev/null +++ b/Haskell/blog/LICENSE.txt @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2021-2022, Gil Mizrahi +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Haskell/blog/Main.hs b/Haskell/blog/Main.hs deleted file mode 100644 index fa740a9..0000000 --- a/Haskell/blog/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Main where - -import Html - -main :: IO () -main = putStrLn - $ render - $ html_ - "My page title" - ( - (h1_ "Hello World!") <> - ( - (p_ "Paragraph #1") <> - (p_ "Paragraph #2") - ) - ) diff --git a/Haskell/blog/README.org b/Haskell/blog/README.org new file mode 100644 index 0000000..937ca98 --- /dev/null +++ b/Haskell/blog/README.org @@ -0,0 +1,5 @@ +* hs-blog + +One day it will be a static blog generator. + +[[https://lhbg-book.link][Read the book]]. diff --git a/Haskell/blog/app/Main.hs b/Haskell/blog/app/Main.hs new file mode 100644 index 0000000..9ed2476 --- /dev/null +++ b/Haskell/blog/app/Main.hs @@ -0,0 +1,50 @@ +module Main where + +import qualified HsBlog +import OptParse + +import System.Exit (exitFailure) +import System.Directory (doesFileExist) +import System.IO + +main :: IO () +main = do + options <- parse + case options of + ConvertDir input output -> + HsBlog.convertDirectory input output + + ConvertSingle input output -> do + (title, inputHandle) <- + case input of + Stdin -> pure ("", stdin) + InputFile file -> (,) file <$> openFile file ReadMode + + outputHandle <- + case output of + Stdout -> pure stdout + OutputFile file -> do + exists <- doesFileExist file + shouldOpenFile <- + if exists + then confirm + else pure True + if shouldOpenFile + then openFile file WriteMode + else exitFailure + + HsBlog.convertSingle title inputHandle outputHandle + hClose inputHandle + hClose outputHandle + + +confirm :: IO Bool +confirm = do + putStrLn "Are you sure? (y/n)" + answer <- getLine + case answer of + "y" -> pure True + "n" -> pure False + _ -> + putStrLn "Invalid response, use y or n" *> + confirm diff --git a/Haskell/blog/app/OptParse.hs b/Haskell/blog/app/OptParse.hs new file mode 100644 index 0000000..c93963a --- /dev/null +++ b/Haskell/blog/app/OptParse.hs @@ -0,0 +1,109 @@ +module OptParse + ( Options(..) + , SingleInput(..) + , SingleOutput(..) + , parse + ) + where + +import Data.Maybe (fromMaybe) +import Options.Applicative + + +data Options + = ConvertSingle SingleInput SingleOutput + | ConvertDir FilePath FilePath + deriving Show + + +data SingleInput + = Stdin + | InputFile FilePath + deriving Show + +data SingleOutput + = Stdout + | OutputFile FilePath + deriving Show + +parse :: IO Options +parse = execParser opts + +opts :: ParserInfo Options +opts = + info (pOptions <**> helper) + ( fullDesc + <> header "hs-blog-gen - a static blog generator" + <> progDesc "Convert markup files or directories to html" + ) + +pOptions :: Parser Options +pOptions = + subparser + ( command + "convert" + ( info + (helper <*> pConvertSingle) + (progDesc "Convert a single markup source to html") + ) + <> command + "convert-dir" + ( info + (helper <*> pConvertDir) + (progDesc "Convert a directory of markup files to html") + ) + ) + +pConvertSingle :: Parser Options +pConvertSingle = ConvertSingle <$> pSingleInput <*> pSingleOutput + +pSingleInput :: Parser SingleInput +pSingleInput = fromMaybe Stdin <$> optional pInputFile + +pSingleOutput :: Parser SingleOutput +pSingleOutput = fromMaybe Stdout <$> optional pOutputFile + +pInputFile :: Parser SingleInput +pInputFile = fmap InputFile parser + where + parser = + strOption + ( long "input" + <> short 'i' + <> metavar "FILE" + <> help "Input file" + ) + +pOutputFile :: Parser SingleOutput +pOutputFile = OutputFile <$> parser + where + parser = + strOption + ( long "output" + <> short 'o' + <> metavar "FILE" + <> help "Output file" + ) + + +pConvertDir :: Parser Options +pConvertDir = ConvertDir <$> pInputDir <*> pOutputDir + + +pInputDir :: Parser FilePath +pInputDir = + strOption + ( long "output" + <> short 'o' + <> metavar "DIRECTORY" + <> help "Output directory" + ) + +pOutputDir :: Parser FilePath +pOutputDir = + strOption + ( long "output" + <> short 'o' + <> metavar "DIRECTORY" + <> help "Output directory" + ) diff --git a/Haskell/blog/hs-blog.cabal b/Haskell/blog/hs-blog.cabal new file mode 100644 index 0000000..34f1f60 --- /dev/null +++ b/Haskell/blog/hs-blog.cabal @@ -0,0 +1,53 @@ +cabal-version: 2.4 + +name: hs-blog +version: 0.1.0.0 +synopsis: A custom blog generator from markup files +description: This package provides a static blog generator + from a custom markup format to HTML. + It defines a parser for this custom markup format + as well as an html pretty printer EDSL. + + It is used as the example project in the online book + 'Learn Haskell Blog Generator'. See the README for + more details. +homepage: https://github.com/soupi/learn-haskell-blog-generator +bug-reports: https://github.com/soupi/learn-haskell-blog-generator/issues +license: BSD-3-Clause +license-file: LICENSE.txt +author: Gil Mizrahi +maintainer: gilmi@posteo.net +category: Learning, Web +extra-doc-files: + README.md + +common common-settings + default-language: Haskell2010 + ghc-options: + -Wall + +library + import: common-settings + hs-source-dirs: src + build-depends: + base + exposed-modules: + HsBlog + HsBlog.Convert + HsBlog.Html + HsBlog.Html.Internal + HsBlog.Markup + +executable hs-blog-gen + import: common-settings + hs-source-dirs: app + main-is: Main.hs + other-modules: + OptParse + build-depends: + base + , directory + , optparse-applicative + , hs-blog + ghc-options: + -O diff --git a/Haskell/blog/package.yaml b/Haskell/blog/package.yaml deleted file mode 100644 index 7c08cd8..0000000 --- a/Haskell/blog/package.yaml +++ /dev/null @@ -1,6 +0,0 @@ -dependencies: - - base == 4.* - - haskell-say -executables: - haskell-hello: - main: Main.hs diff --git a/Haskell/blog/src/HsBlog.hs b/Haskell/blog/src/HsBlog.hs new file mode 100644 index 0000000..2a2bc4e --- /dev/null +++ b/Haskell/blog/src/HsBlog.hs @@ -0,0 +1,23 @@ +module HsBlog + ( convertSingle + , convertDirectory + , process + ) + where + +import qualified HsBlog.Html as Html +import qualified HsBlog.Markup as Markup + +import HsBlog.Convert (convert) +import System.IO + +process :: Html.Title -> String -> String +process title = Html.render . convert title . Markup.parse + +convertSingle :: Html.Title -> Handle -> Handle -> IO () +convertSingle title input output = do + content <- hGetContents input + hPutStrLn output (process title content) + +convertDirectory :: FilePath -> FilePath -> IO () +convertDirectory = error "Not emplemented" diff --git a/Haskell/blog/src/HsBlog/Convert.hs b/Haskell/blog/src/HsBlog/Convert.hs new file mode 100644 index 0000000..f6d099c --- /dev/null +++ b/Haskell/blog/src/HsBlog/Convert.hs @@ -0,0 +1,20 @@ +module HsBlog.Convert where + +import qualified HsBlog.Markup as Markup +import qualified HsBlog.Html as Html + +convert :: Html.Title -> Markup.Document -> Html.Html +convert title = Html.html_ title . foldMap convertStructure + +convertStructure :: Markup.Structure -> Html.Structure +convertStructure structure = + case structure of + Markup.Heading n txt -> Html.h_ n txt + + Markup.Paragraph p -> Html.p_ p + + Markup.UnorderedList list -> Html.ul_ $ map Html.p_ list + + Markup.OrderedList list -> Html.ol_ $ map Html.p_ list + + Markup.CodeBlock list -> Html.code_ $ unlines list diff --git a/Haskell/blog/Html.hs b/Haskell/blog/src/HsBlog/Html.hs similarity index 55% rename from Haskell/blog/Html.hs rename to Haskell/blog/src/HsBlog/Html.hs index 27c14e7..d690b67 100644 --- a/Haskell/blog/Html.hs +++ b/Haskell/blog/src/HsBlog/Html.hs @@ -1,15 +1,20 @@ -module Html +module HsBlog.Html ( Html , Title , Structure , html_ , p_ + , h_ , h1_ + , ul_ + , ol_ , body_ , head_ , title_ + , code_ + , empty_ , render ) where -import Html.Internal +import HsBlog.Html.Internal diff --git a/Haskell/blog/Html/Internal.hs b/Haskell/blog/src/HsBlog/Html/Internal.hs similarity index 82% rename from Haskell/blog/Html/Internal.hs rename to Haskell/blog/src/HsBlog/Html/Internal.hs index 9ea30fd..8a93fad 100644 --- a/Haskell/blog/Html/Internal.hs +++ b/Haskell/blog/src/HsBlog/Html/Internal.hs @@ -1,4 +1,6 @@ -module Html.Internal where +module HsBlog.Html.Internal where + +import Numeric.Natural -- * Types @@ -11,6 +13,14 @@ type Title = String instance Semigroup Structure where (<>) c1 c2 = Structure (getStructuredString c1 <> getStructuredString c2) +instance Monoid Structure where + mempty = empty_ + + mconcat list = + case list of + [] -> mempty + x : xs -> x <> mconcat xs + -- * EDSL html_ :: Title -> Structure -> Html @@ -31,6 +41,9 @@ title_ = Structure . el "title" p_ :: String -> Structure p_ = Structure . el "p" . escape +h_ :: Natural -> String -> Structure +h_ level = Structure . el ("h" ++ show level) . escape + h1_ :: String -> Structure h1_ = Structure . el "h1" . escape @@ -43,6 +56,9 @@ ol_ = list "ol" code_ :: String -> Structure code_ = Structure . el "pre" . escape +empty_ :: Structure +empty_ = Structure "" + -- * Render render :: Html -> String diff --git a/Haskell/blog/Markup.hs b/Haskell/blog/src/HsBlog/Markup.hs similarity index 98% rename from Haskell/blog/Markup.hs rename to Haskell/blog/src/HsBlog/Markup.hs index b2530e8..fdca7e4 100644 --- a/Haskell/blog/Markup.hs +++ b/Haskell/blog/src/HsBlog/Markup.hs @@ -1,6 +1,7 @@ -module Markup +module HsBlog.Markup ( Document , Structure(..) + , parse ) where -- 2.51.2