reflex-dom-th (empty) → 0.1.0.0
raw patch · 6 files changed
+374/−0 lines, 6 filesdep +arraydep +basedep +bytestring
Dependencies added: array, base, bytestring, containers, filepath, hspec, megaparsec, reflex-dom-core, reflex-dom-th, stm, tasty, tasty-golden, tasty-hspec, template-haskell, text
Files
- CHANGELOG.md +5/−0
- README.md +44/−0
- reflex-dom-th.cabal +82/−0
- src/Reflex/Dom/TH.hs +121/−0
- src/Reflex/Dom/TH/Parser.hs +92/−0
- tests/test.hs +30/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for reflex-dom-th++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ README.md view
@@ -0,0 +1,44 @@+# reflex-dom-th+Do you develop for the web? And you know functional reactive programming is the way to go. So you must use Reflex-DOM.+But how can you integrate all these HTML snippet, which you found. You are tired in converting everything to to el, elAttr' etc, right?++From this day on this reflex-dom-th library will automate the task of converting your HTML templates to Reflex-Dom.++# Examples++The basic example++ [dom|<div>hello</div>|]++is equivalent to++ el "div" $ text "hello"++You can also put the html in a external file and include it with++ $(domFile "template.html")++It it possible to have multiple elements and attributes++ [dom|<ul class="list">+ <li>Item1</div>+ <li>Item1</div>+ </ul> |]++Dynamic content can be injected two curly braces++ [dom|<ul class="list">+ <li>{{item1}}</div>+ <li>{{item2}}</div>+ </ul> |]+ where item1, item2 :: MonadWidget t m => m ()+ item1 = text "Item1"+ item2 = text "Item2"+++To bind events to the elements it is possible to extract get the elements as a result. The reference number is the position in the result tuple.++ (li1, li2, ul) <- [dom|<ul #2 class="list">+ <li #0>Item1</div>+ <li #1>Item1</div>+ </ul> |]
+ reflex-dom-th.cabal view
@@ -0,0 +1,82 @@+cabal-version: 2.4+name: reflex-dom-th+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: reflex-dom-th transpiles HTML templates to haskell code for @reflex-dom@++-- A longer description of the package.+description:+ Reflex-DOM is a very powerful web framework for functional reactive programming (FRP).+ Web pages itself are written in HTML.+ .+ @reflex-dom-th@ combines the power of these two techniques by transpiling HTML templates to Haskell for the @reflex-dom@ library.+ + +Stability: Experimental+-- A URL where users can report bugs.+bug-reports: https://github.com/chrbauer/reflex-dom-th/issues++license: BSD-3-Clause+author: Christoph Bauer+maintainer: mail@christoph-bauer.net++-- A copyright notice.+-- copyright:+category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface+extra-source-files: CHANGELOG.md, README.md++library+ build-depends:+ base+ , megaparsec + exposed-modules:+ Reflex.Dom.TH.Parser+ , Reflex.Dom.TH+ default-extensions: TemplateHaskell, TupleSections, DeriveLift, RecordWildCards, QuasiQuotes, OverloadedStrings+ build-depends:+ base >= 4 && < 5+ , array+ , containers+ , megaparsec+ , reflex-dom-core+ , template-haskell+ , text+ ghc-options: -Wall -fwarn-tabs+ hs-source-dirs: src+ default-language: Haskell2010+++test-suite test-reflex-dom-th+ default-language:+ Haskell2010+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ tests+ main-is:+ test.hs+ build-depends:+ base >= 4 && < 5+ , bytestring+ , filepath+ , megaparsec+ , hspec+ , reflex-dom-th+ , stm >= 2.5.0.2+ , tasty+ , tasty-golden+ , tasty-hspec+ --, hspec-megaparsec++ + --, tasty-hspec+ +-- executable ref-dom-th-example+-- hs-source-dirs: example+-- main-is: Main.hs+-- build-depends:+-- base >= 4 && < 5+-- , reflex-dom++
+ src/Reflex/Dom/TH.hs view
@@ -0,0 +1,121 @@+-- | ++module Reflex.Dom.TH+ (dom, domFile, merge)+where+++import Text.Megaparsec.Error++import Language.Haskell.TH.Quote+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Reflex.Dom.TH.Parser+import Reflex.Dom.Widget.Basic +import qualified Data.Map as M+import Data.Map (Map)+--import Data.Maybe+import Data.List (insert)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Array++type Ref = Int+data CElement = CElement { cTag :: String+ , cSiblingsRefs :: [Ref]+ , cChildRefs :: [Ref]+ , cOutRefs :: [Ref]+ , cMyRef :: Maybe Ref+ , cAttrs :: [(String, String)]+ , cChilds :: [CElement] }+ | CText String+ | CComment String+ | CWidget String+ deriving Show++merge :: Ord a => [a] -> [a] -> [a]+merge a [] = a+merge [] b = b+merge a@(ah:at) b@(bh:bt)+ | compare ah bh == GT = bh : merge a bt+ | otherwise = ah : merge at b+++-- do (r1, (r1a, r1b)) <- el1 $ el1a >>= \ r1a -> el1b >>= \r1b -> return (r1a, r1b)++++compile :: [TElement] -> [CElement] -> [Ref] -> ([CElement], [Ref])+compile [] acc inRefs = (reverse acc, inRefs)+compile ((TElement {..}):etail) acc inRefs =+ compile etail (elem':acc) expRefs+ where+ elem' = CElement tTag inRefs childRefs outRefs tRef attrs childs+ (childs, childRefs) = compile tChilds [] []+ outRefs = maybe id insert tRef childRefs+ expRefs = merge inRefs outRefs+ attrs = [ (k, v) | (Static, k, v) <- tAttrs ]+compile (elem:etail) acc inRefs =+ compile etail (toC elem : acc) inRefs+ where+ toC (TText text) = CText text+ toC (TComment comment) = CComment comment+ toC (TWidget widget) = CWidget widget+ toC _ = undefined+ +++opt :: (Ref -> Name) -> Maybe Ref -> Q Pat+opt var = maybe (runQ [p| () |]) $ varP . var++clambda var Nothing crefs = lamE [tupP $ map (varP . var) crefs ]+clambda var mref crefs = lamE [tupP [ opt var mref+ , tupP $ map (varP . var) crefs]]+++cnodes :: (Ref -> Name) -> [CElement] -> ExpQ+cnodes _ [] = [| blank |]+cnodes var [elem@(CElement _ _ crefs orefs mref _ _)] + | null orefs = [| $(cnode var elem) |]+ | otherwise = [| $(cnode var elem) >>= $(clambda var mref crefs (appE (varE 'return) (tupE $ map (varE . var) orefs))) |]+cnodes var (elem@(CElement _ _ crefs orefs mref _ _):rest) = [| $(cnode var elem) >>= $(clambda var mref crefs (cnodes var rest)) |]+ +cnodes var [elem] = cnode var elem+cnodes var (h:t) = [| $(cnode var h) >> $(cnodes var t) |]++cnode :: (Ref -> Name) -> CElement -> ExpQ+cnode var (CElement tag _ _ _ Nothing attr childs) = [| elAttr tag (M.fromList attr) $(cnodes var childs)|]+cnode var (CElement tag _ _ _ (Just _) attr childs) = [| elAttr' tag (M.fromList attr) $(cnodes var childs) |]+cnode _ (CText "") = [| blank |]+cnode _ (CText txt) = [| text txt |]+cnode _ (CWidget x) = unboundVarE $ mkName x+cnode _ (CComment txt) = [| comment txt |]++domExp :: [TElement] -> Q Exp+domExp result =+ let (cns, out) = compile result [] [] in do+ varNames <- listArray (0, length out) <$> mapM (\ r -> newName ("r" ++ show r)) out+ cnodes (varNames !) cns++dom :: QuasiQuoter+dom = QuasiQuoter+ { quoteExp = \str ->+ case parseTemplate "" str of+ Left err -> fail $ errorBundlePretty err+ Right result -> domExp result+ , quotePat = error "Usage as a parttern is not supported"+ , quoteType = error "Usage as a type is not supported"+ , quoteDec = error "Usage as a decl is not supported"++ }+++domFile :: FilePath -> Q Exp+domFile path = do+ str <- runIO (readFile path)+ addDependentFile path+ case parseTemplate path str of+ Left err -> fail $ errorBundlePretty err+ Right result -> domExp result+
+ src/Reflex/Dom/TH/Parser.hs view
@@ -0,0 +1,92 @@+-- | ++module Reflex.Dom.TH.Parser+( TElement(..),+ AttributeType(..),+ parseTemplate+ )+where++import Data.Char+import Data.List+++import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L +import Data.Void+import Control.Monad+import Language.Haskell.TH.Syntax++type Parser = Parsec Void String+type TTag = String+data AttributeType = Static | Dynamic deriving (Show, Lift)+type Attribute = (AttributeType, String, String)+type Ref = Int+data TElement = TElement { tTag :: TTag+ , tRef :: Maybe Ref+ , tAttrs :: [Attribute]+ , tChilds :: [TElement] }+ | TText String+ | TComment String+ | TWidget String+ deriving Show+++openTag :: Parser (String, Maybe Int, [Attribute])+openTag = + between (char '<') (char '>') $ do+ tag <- many (alphaNumChar <|> char '-')+ space+ ref <- optional $ do+ void $ char '#'+ L.decimal <* space+ attrs <- attributes+ space+ return (tag, ref, attrs)++closeTag :: String -> Parser ()+closeTag tag = void $ between (string "</") (space >> char '>') (string tag)++comment :: Parser TElement+comment = TComment <$> ((string "<!--") *> (manyTill anySingle (string "-->")))+++stringLiteral :: Parser String+stringLiteral = char '\"' *> manyTill L.charLiteral (char '\"')++attribute :: Parser Attribute+attribute = (Static,,) <$> (some alphaNumChar <* char '=') <*> stringLiteral+++attributes :: Parser [Attribute]+attributes = sepBy attribute space1 <* space+ ++node :: Parser TElement+node = do+ (tag, ref, attrs) <- openTag+ space+ childs <- manyTill element (closeTag tag)+ return $ TElement tag ref attrs childs+++widget :: Parser TElement+widget = TWidget <$> (string "{{" *> manyTill anySingle (string "}}"))++text :: Parser TElement+text = TText <$> dropWhileEnd isSpace <$> some (satisfy (/= '<'))++element :: Parser TElement +element = (comment <|> node <|> widget <|> text) <* space+ +template :: Parser [TElement]+template = do+ space+ result <- many element+ eof+ return result+++parseTemplate :: FilePath -> String -> Either (ParseErrorBundle String Void) [TElement]+parseTemplate fn = runParser template fn
+ tests/test.hs view
@@ -0,0 +1,30 @@+import Test.Tasty (defaultMain, TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString, findByExtension)+import System.IO (readFile)+import Reflex.Dom.TH.Parser+import System.FilePath (takeBaseName, replaceExtension)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as L+import Text.Megaparsec++main :: IO ()+main = defaultMain =<< goldenTests+++templateToAst :: String -> LBS.ByteString -> LBS.ByteString+templateToAst path = L.pack . render . parseTemplate path . L.unpack+ where render (Right x) = show x+ render (Left err) = errorBundlePretty err+ ++goldenTests :: IO TestTree+goldenTests = do+ htmlFiles <- findByExtension [".html"] "."+ return $ testGroup "Html Template Parser golden tests"+ [ goldenVsString+ (takeBaseName htmlFile) + astFile+ (templateToAst htmlFile <$> LBS.readFile htmlFile) + | htmlFile <- htmlFiles+ , let astFile = replaceExtension htmlFile ".ast"+ ]