Shpadoinkle-template 0.0.0.1 → 0.0.0.2
raw patch · 5 files changed
+172/−50 lines, 5 filesdep +directorydep +html-entitiesdep +process
Dependencies added: directory, html-entities, process
Files
- CHANGELOG.md +0/−0
- README.md +1/−1
- Shpadoinkle-template.cabal +54/−32
- Shpadoinkle/Template/TH.hs +107/−13
- Test.hs +10/−4
− CHANGELOG.md
README.md view
@@ -1,6 +1,6 @@ # Shpadoinkle Template -[](https://gitlab.com/fresheyeball/Shpadoinkle)+[](https://gitlab.com/platonic/shpadoinkle) [](https://shpadoinkle.org/template) [](https://opensource.org/licenses/BSD-3-Clause) [](https://builtwithnix.org)
Shpadoinkle-template.cabal view
@@ -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
Shpadoinkle/Template/TH.hs view
@@ -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)
Test.hs view
@@ -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 = "<divyoddle yoddleclass=\"baryoddle\"><span>Hi yoddle</span></divyoddle>"- 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