diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for reflex-dom-th -## 0.1.0.0 -- YYYY-mm-dd +## 0.2.0.0 -- 2022-02-18 + +* specialization to el-variants +* parse widgets inside texts +* allow refs to widgets +* dash '-' is now valid in attribute names + + + +## 0.1.0.0 -- 2022-02-18 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,37 +8,51 @@ The basic example - [dom|
hello
|] +``` +[dom|
hello
|] +``` is equivalent to - el "div" $ text "hello" +``` +el "div" $ text "hello" +``` You can also put the html in a external file and include it with - $(domFile "template.html") +``` +$(domFile "template.html") +``` It it possible to have multiple elements and attributes - [dom| |] +``` +[dom| |] +``` -Dynamic content can be injected two curly braces +Dynamic content can be injected between two curly braces. It will reference an unbound variable. It is not a haskell expression. Keeping haskell out of the template will give you better error messages. - [dom| |] - where item1, item2 :: MonadWidget t m => m () - item1 = text "Item1" - item2 = text "Item2" +``` +[dom| |] + 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| |] +``` +(li1, li2, ul, w) <- [dom| |] +``` + diff --git a/reflex-dom-th.cabal b/reflex-dom-th.cabal --- a/reflex-dom-th.cabal +++ b/reflex-dom-th.cabal @@ -1,9 +1,9 @@ cabal-version: 2.4 name: reflex-dom-th -version: 0.1.0.0 +version: 0.2.0.0 -- A short (one-line) description of the package. -synopsis: reflex-dom-th transpiles HTML templates to haskell code for @reflex-dom@ +synopsis: reflex-dom-th transpiles HTML templates to haskell code for reflex-dom -- A longer description of the package. description: @@ -16,7 +16,7 @@ Stability: Experimental -- A URL where users can report bugs. bug-reports: https://github.com/chrbauer/reflex-dom-th/issues - +homepage: https://github.com/chrbauer/reflex-dom-th license: BSD-3-Clause author: Christoph Bauer maintainer: mail@christoph-bauer.net diff --git a/src/Reflex/Dom/TH.hs b/src/Reflex/Dom/TH.hs --- a/src/Reflex/Dom/TH.hs +++ b/src/Reflex/Dom/TH.hs @@ -1,7 +1,7 @@ -- | module Reflex.Dom.TH - (dom, domFile, merge) + (dom, domFile) where @@ -14,24 +14,30 @@ 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 ChildResult = + CREmpty + | CRSimple Ref + | CRTuple (Maybe Ref) [Ref] + deriving Show + +data Chain = CBind CElement ChildResult Chain | CResult [Ref] + deriving Show + data CElement = CElement { cTag :: String , cSiblingsRefs :: [Ref] , cChildRefs :: [Ref] , cOutRefs :: [Ref] , cMyRef :: Maybe Ref , cAttrs :: [(String, String)] - , cChilds :: [CElement] } + , cChilds :: Chain } | CText String | CComment String - | CWidget String + | CWidget String (Maybe Ref) deriving Show merge :: Ord a => [a] -> [a] -> [a] @@ -42,61 +48,72 @@ | 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 +compile :: [TElement] -> [Ref] -> Chain +compile [] inRefs = CResult inRefs +compile ((TElement {..}):etail) inRefs = + CBind elem' (CRTuple tRef childRefs) (compile etail expRefs) where - elem' = CElement tTag inRefs childRefs outRefs tRef attrs childs - (childs, childRefs) = compile tChilds [] [] - outRefs = maybe id insert tRef childRefs + elem' = CElement tTag inRefs childRefs outRefs tRef attrs childChain + childChain = compile tChilds [] + childRefs = chainOut childChain + 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 + +compile (TWidget w r:etail) inRefs = CBind (CWidget w r) (maybe CREmpty CRSimple r) (compile etail expRefs) + where expRefs = maybe id insert r inRefs +compile (e:etail) inRefs = + CBind (toC e) CREmpty (compile etail inRefs) where - toC (TText text) = CText text - toC (TComment comment) = CComment comment - toC (TWidget widget) = CWidget widget - toC _ = undefined + toC (TText t) = CText t + toC (TComment c) = CComment c + toC _ = error "internal" 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]] +clambda :: (Ref -> Name) -> ChildResult -> ExpQ -> ExpQ +clambda _ CREmpty = lamE [wildP] +clambda var (CRSimple v) = lamE [tupP [varP $ var v]] +clambda var (CRTuple Nothing crefs) = lamE [tupP $ map (varP . var) crefs] +clambda var (CRTuple mref crefs) = lamE [tupP [ opt var mref + , tupP $ map (varP . var) crefs]] +elWithAttr :: String -> [(String, String)] -> ExpQ +elWithAttr tag [] = [| el tag |] +elWithAttr tag [("class", cl)] = [| elClass tag cl |] +elWithAttr tag attr = [| elAttr tag (M.fromList attr) |] +el'WithAttr :: String -> [(String, String)] -> ExpQ +el'WithAttr tag [] = [| el' tag |] +el'WithAttr tag [("class", cl)] = [| elClass' tag cl |] +el'WithAttr tag attr = [| elAttr' tag (M.fromList attr) |] -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) |] +cchain :: (Ref -> Name) -> Chain -> ExpQ +cchain var (CResult orefs) = (appE (varE 'return) (tupE $ map (varE . var) orefs)) +cchain var (CBind ce cres rest) = [| $(cnode var ce) >>= $(clambda var cres (cchain var rest)) |] + 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 var (CElement tag _ _ _ Nothing attr childs) = [| $(elWithAttr tag attr) $(cchain var childs)|] +cnode var (CElement tag _ _ _ (Just _) attr childs) = [| $(el'WithAttr tag attr) $(cchain var childs) |] cnode _ (CText "") = [| blank |] cnode _ (CText txt) = [| text txt |] -cnode _ (CWidget x) = unboundVarE $ mkName x +cnode _ (CWidget x _) = unboundVarE $ mkName x cnode _ (CComment txt) = [| comment txt |] +chainOut :: Chain -> [Ref] +chainOut (CBind _ _ next) = chainOut next +chainOut (CResult out) = out + domExp :: [TElement] -> Q Exp domExp result = - let (cns, out) = compile result [] [] in do + let refchain = compile result [] + out = chainOut refchain + in do varNames <- listArray (0, length out) <$> mapM (\ r -> newName ("r" ++ show r)) out - cnodes (varNames !) cns + cchain (varNames !) refchain dom :: QuasiQuoter dom = QuasiQuoter diff --git a/src/Reflex/Dom/TH/Parser.hs b/src/Reflex/Dom/TH/Parser.hs --- a/src/Reflex/Dom/TH/Parser.hs +++ b/src/Reflex/Dom/TH/Parser.hs @@ -29,24 +29,27 @@ , tChilds :: [TElement] } | TText String | TComment String - | TWidget String + | TWidget String (Maybe Ref) deriving Show +refOpt :: Parser (Maybe Int) +refOpt = optional . try $ do + space1 + void $ char '#' + L.decimal <* space openTag :: Parser (String, Maybe Int, [Attribute]) openTag = between (char '<') (char '>') $ do tag <- many (alphaNumChar <|> char '-') + ref <- refOpt space - ref <- optional $ do - void $ char '#' - L.decimal <* space attrs <- attributes space return (tag, ref, attrs) closeTag :: String -> Parser () -closeTag tag = void $ between (string "> char '>') (string tag) +closeTag tag = void $ between (string "> space) (char '>') (string tag >> space) comment :: Parser TElement comment = TComment <$> ((string ""))) @@ -56,7 +59,7 @@ stringLiteral = char '\"' *> manyTill L.charLiteral (char '\"') attribute :: Parser Attribute -attribute = (Static,,) <$> (some alphaNumChar <* char '=') <*> stringLiteral +attribute = (Static,,) <$> (some (alphaNumChar <|> char '-') <* char '=') <*> stringLiteral attributes :: Parser [Attribute] @@ -70,12 +73,14 @@ childs <- manyTill element (closeTag tag) return $ TElement tag ref attrs childs +varName :: Parser String +varName = (:) <$> lowerChar <*> many alphaNumChar widget :: Parser TElement -widget = TWidget <$> (string "{{" *> manyTill anySingle (string "}}")) +widget = TWidget <$> (string "{{" *> space *> varName) <*> (refOpt <* (string "}}")) text :: Parser TElement -text = TText <$> dropWhileEnd isSpace <$> some (satisfy (/= '<')) +text = TText <$> dropWhileEnd isSpace <$> someTill anySingle (lookAhead (char '<' *> return () <|> string "{{" *> return () )) element :: Parser TElement element = (comment <|> node <|> widget <|> text) <* space