diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Shpadoinkle Template -[![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle) +[![Goldwater](https://gitlab.com/platonic/shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/platonic/shpadoinkle) [![Haddock](https://img.shields.io/badge/haddock-master-informational)](https://shpadoinkle.org/template) [![BSD-3](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) [![built with nix](https://img.shields.io/badge/built%20with-nix-41439a)](https://builtwithnix.org) diff --git a/Shpadoinkle-template.cabal b/Shpadoinkle-template.cabal --- a/Shpadoinkle-template.cabal +++ b/Shpadoinkle-template.cabal @@ -1,62 +1,84 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: b12f6991d22c408f646249268554550793acbdcedcc5d8b448606f1de6cda389 - -name: Shpadoinkle-template -version: 0.0.0.1 -synopsis: Read standard file formats into Shpadoinkle with Template Haskell -description: This package provides TH functions to read files at compile time and embed them into Shpadoinkle views. -category: Web -author: Isaac Shapira -maintainer: fresheyeball@protonmail.com -license: BSD3 -license-file: LICENSE -build-type: Simple +cabal-version: 2.2 +name: Shpadoinkle-template +version: 0.0.0.2 +category: Web +author: Isaac Shapira +maintainer: isaac.shapira@platonic.systems +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple extra-source-files: - README.md - CHANGELOG.md + README.md +synopsis: + Read standard file formats into Shpadoinkle with Template Haskell +description: + This package provides TH functions to read files at compile time + and embed them into Shpadoinkle views. + source-repository head type: git - location: https://gitlab.com/fresheyeball/Shpadoinkle.git + location: https://gitlab.com/platonic/shpadoinkle.git + +common ghc-options + ghc-options: + -Wall + -Wcompat + -fwarn-redundant-constraints + -fwarn-incomplete-uni-patterns + -fwarn-tabs + -fwarn-incomplete-record-updates + -fwarn-identities + + library + import: ghc-options + exposed-modules: - Shpadoinkle.Template.TH - Shpadoinkle.Template - hs-source-dirs: - ./. - ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities + Shpadoinkle.Template.TH + Shpadoinkle.Template + + hs-source-dirs: . + build-depends: Shpadoinkle , Shpadoinkle-backend-static , base >=4.12.0 && <4.16 + , directory + , process , html-parse , template-haskell , text >=1.2.3 && <1.3 + , html-entities + default-language: Haskell2010 + test-suite sample + import: ghc-options + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: - Shpadoinkle.Template - Shpadoinkle.Template.TH - Paths_Shpadoinkle_template - hs-source-dirs: - ./. - ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities + Shpadoinkle.Template + Shpadoinkle.Template.TH + + hs-source-dirs: . + build-depends: Shpadoinkle , Shpadoinkle-backend-static , Shpadoinkle-template , base >=4.12.0 && <4.16 + , directory + , process , file-embed , html-parse , template-haskell , text >=1.2.3 && <1.3 + , html-entities + default-language: Haskell2010 diff --git a/Shpadoinkle/Template/TH.hs b/Shpadoinkle/Template/TH.hs --- a/Shpadoinkle/Template/TH.hs +++ b/Shpadoinkle/Template/TH.hs @@ -1,39 +1,106 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Shpadoinkle.Template.TH where -import Data.Text (Text, cons, unpack) +import Control.Monad (unless, when) +import Data.Maybe (fromMaybe) +import Data.Text (Text, cons, head, null, pack, + replace, tail, uncons, unpack) import Data.Text.IO +import HTMLEntities.Decoder (htmlEntityBody) import Language.Haskell.TH.Syntax -import Prelude hiding (readFile) +import Prelude hiding (head, null, readFile, tail) +import System.Directory (doesFileExist, removeFile) +import System.Exit (ExitCode (..)) +import System.Process (proc, + readCreateProcessWithExitCode) import Text.HTML.Parser (Attr (..), Token (..), parseTokens) + +data CleanUp = CleanUp | LeaveFile deriving Eq + + +embedAsciidoc :: FilePath -> Q Exp +embedAsciidoc asciiPath = do + let htmlPath = unpack $ replace ".adoc" ".html" $ pack asciiPath + out@(exit, _, _) <- runIO $ do + doesAscii <- doesFileExist asciiPath + _ <- unless doesAscii . fail $ "Document not found at " <> asciiPath + doesHtml <- doesFileExist htmlPath + when doesHtml $ removeFile htmlPath + readCreateProcessWithExitCode (proc "asciidoctor" [ "-s", asciiPath ]) "" + case exit of + ExitSuccess -> embedHtml' CleanUp htmlPath + ExitFailure _ -> fail $ show out + + embedHtml :: FilePath -> Q Exp -embedHtml path = do - ts <- runIO $ parseTokens <$> readFile path +embedHtml = embedHtml' LeaveFile + + +embedHtml' :: CleanUp -> FilePath -> Q Exp +embedHtml' clean htmlPath = do + ts <- runIO $ do + doesHtml <- doesFileExist htmlPath + _ <- unless doesHtml . fail $ "Html not found at " <> htmlPath + ts' <- parseTokens <$> readFile htmlPath + when (clean == CleanUp) $ removeFile htmlPath + return ts' pure . ListE $ tokenToExp ts +breakClosing :: Text -> [Token] -> ([Token],[Token]) +breakClosing tn = go (0 :: Int) + where + + sameTag = \case + TagOpen tn' _ | tn' == tn -> True + TagClose tn' | tn' == tn -> True + _ -> False + + go depth ts = case break sameTag ts of + + -- closing tag at the top level, we are done + (before, t@(TagClose tn':_)) + | tn' == tn && depth == 0 -> (before, t) + + -- closing tag found at a deeper level, collect and decrement + (before, t@(TagClose tn'):more) + | tn' == tn -> let (before', rest') = go (depth - 1) more + in (before <> [t] <> before', rest') + + -- sibling opening tag found, decend + (before, t@(TagOpen tn' _):children) + | tn == tn' -> let (before', rest') = go (depth + 1) children + in (before <> [t] <> before', rest') + + x -> x + + + tokenToExp :: [Token] -> [Exp] tokenToExp = let h = UnboundVarE $ mkName "h" text = UnboundVarE $ mkName "text" in \case + TagOpen "hr" attrs:ts -> tokenToExp $ TagSelfClose "hr" attrs:ts TagOpen tn attrs:ts -> let attrs' = ListE $ attrToExp <$> attrs name = asText tn - (children, siblings) = break (\case TagClose tn' | tn' == tn -> True; _ -> False) ts - in AppE (AppE (AppE h name) attrs') (ListE $ tokenToExp children) : tokenToExp (drop 1 siblings) + (children, siblings) = breakClosing tn ts + in AppE (AppE (AppE h name) attrs') (ListE $ tokenToExp children) : tokenToExp siblings TagSelfClose tn attrs:ts -> let attrs' = ListE $ attrToExp <$> attrs name = asText tn in AppE (AppE (AppE h name) attrs') (ListE []) : tokenToExp ts TagClose _:ts -> tokenToExp ts ContentText content:ts -> - let content' = asText content - in AppE text content' : tokenToExp ts + if content == "\56608" + then tokenToExp ts else let content' = asText content + in AppE text content' : tokenToExp ts ContentChar char:ts -> let char' = asText $ cons char mempty in AppE text char' : tokenToExp ts @@ -44,10 +111,37 @@ attrToExp :: Attr -> Exp attrToExp (Attr name value) = TupE [name', AppE textProp value'] - where textProp = UnboundVarE $ mkName "textProp" - name' = asText name - value' = asText value + where + textProp = UnboundVarE $ mkName "textProp" + name' = asText $ case name of + "class" -> "className" + _ -> name + value' = asText value asText :: Text -> Exp -asText = AppE (UnboundVarE $ mkName "pack") . LitE . StringL . unpack +asText = AppE (UnboundVarE $ mkName "pack") . LitE . StringL . unpack . decodeHtml + + +decodeHtml :: Text -> Text +decodeHtml s = case uncons s of + Nothing -> "" + Just ('&', xs) -> fromMaybe ('&' `cons` decodeHtml xs) $ do + (before, after) <- breakCharMaybe ';' xs + c <- hush $ htmlEntityBody before + return $ c <> decodeHtml after + Just (x, xs) -> x `cons` decodeHtml xs + + +hush :: Either a b -> Maybe b +hush (Left _) = Nothing +hush (Right x) = Just x + + +breakCharMaybe :: Char -> Text -> Maybe (Text, Text) +breakCharMaybe c s + | null s = Nothing + | c == head s = Just ("", tail s) + | otherwise = do + (next, rest) <- breakCharMaybe c (tail s) + Just (cons (head s) next, rest) diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -18,9 +18,12 @@ testHtmlIngestion = let x = mconcat $ renderStatic <$> $(embedHtml "./test.html") y = decodeUtf8 $(embedFile "./test.html") - in if x == y then pure () else - error $ "test.html did not parse correctly. Got: " ++ unpack x + in if x == y then pure () else do + print x + print y + error "test.html did not parse correctly. Got: " + testTemplate :: IO () testTemplate = let x = renderStatic $ template (replace "{{x}}" "yoddle") $ @@ -28,8 +31,11 @@ [ h "span" [] [ "Hi {{x}}" ] ] y = "Hi yoddle" - in if x == y then pure () else - error $ "template did not interpolate. Got: " ++ unpack x + in if x == y then pure () else do + print x + print y + error "template did not interpolate." + main :: IO () main = do