diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for plzwrk +## 0.0.0.8 + +- Fixes a bug in the HSX parser that rejected certain valid text nodes + ## 0.0.0.7 - Removes spurious dependencies for faster build. diff --git a/plzwrk.cabal b/plzwrk.cabal --- a/plzwrk.cabal +++ b/plzwrk.cabal @@ -7,7 +7,7 @@ -- hash: 8099ceb0d406f862d89306de053aba4c75999a9e0d74ac6a502458d503e7dcc1 name: plzwrk -version: 0.0.0.7 +version: 0.0.0.8 category: Web synopsis: A front-end framework description: Please see the README on GitHub at diff --git a/src/Web/Framework/Plzwrk/TH/HSX.hs b/src/Web/Framework/Plzwrk/TH/HSX.hs --- a/src/Web/Framework/Plzwrk/TH/HSX.hs +++ b/src/Web/Framework/Plzwrk/TH/HSX.hs @@ -1,134 +1,146 @@ -module Web.Framework.Plzwrk.TH.HSX - ( HSXAttribute(..) - , HSX(..) - , parseHSX - ) -where - -import Control.Applicative ( (<*) - , (*>) - , (<$>) - , (<$) - ) -import Control.Monad ( void ) -import qualified Control.Monad.Fail as MF -import Data.Char -import Data.List ( foldl' ) -import Text.Parsec -import Text.Parsec.String - -data HSXAttribute = HSXStringAttribute String - | HSXHaskellCodeAttribute String - | HSXHaskellTxtAttribute String deriving (Show, Eq) - -data HSX = HSXElement String [(String, HSXAttribute)] [HSX] - | HSXSelfClosingTag String [(String, HSXAttribute)] - | HSXHaskellCode String - | HSXHaskellCodeList String - | HSXHaskellText String - | HSXBody String - deriving (Show, Eq) - -hsx :: Parser HSX -hsx = tag - -tag = do - char '<' - ws - name <- many (letter <|> digit) - ws - attr <- many attribute - ws - close <- try (string "/>" <|> string ">") - if (length close) == 2 - then return (HSXSelfClosingTag name attr) - else do - elementHSXBody <- manyTill elementHSXBody (endTag name) - ws - return (HSXElement name attr elementHSXBody) - -elementHSXBody = - ws - *> ( try tag - <|> try haskellCodeNode - <|> try haskellCodeNodes - <|> try haskellTxtNode - <|> text - ) - -endTag :: String -> Parser String -endTag str = string " string str <* char '>' - -text = HSXBody <$> many1 (noneOf "><") - -stringAttribute = do - char '"' - value <- many (noneOf ['"']) - char '"' - return $ HSXStringAttribute value - -haskellTxtAttr = do - string "#t{" - value <- manyTill anyChar (string "}#") - ws - return $ HSXHaskellTxtAttribute value - -makeBracketed cmd contain = do - let start = ("#" <> cmd <> "{") - let end = "}#" - string start - value <- manyTill anyChar (string end) - ws - return $ if (contain) then start <> value <> end else value - -haskellCodeAttr = do - value <- makeBracketed "c" False - return $ HSXHaskellCodeAttribute value - -haskellCodeNode :: Parser HSX -haskellCodeNode = do - value <- makeBracketed "e" False - return $ HSXHaskellCode value - -haskellCodeNodes :: Parser HSX -haskellCodeNodes = do - value <- makeBracketed "el" False - return $ HSXHaskellCodeList value - -haskellTxtNode :: Parser HSX -haskellTxtNode = do - value <- makeBracketed "t" False - return $ HSXHaskellText value - -attribute = do - name <- many (noneOf "= />") - ws - char '=' - ws - value <- stringAttribute <|> (try haskellCodeAttr) <|> haskellTxtAttr - ws - return (name, value) - -ws :: Parser () -ws = void $ many $ oneOf " \t\r\n" - -parseHSX :: MonadFail m => (String, Int, Int) -> String -> m HSX -parseHSX (file, line, col) s = case runParser p () "" s of - Left err -> MF.fail $ show err - Right e -> return e - where - p = do - updatePosition file line col - ws - e <- hsx - ws - eof - return e - -updatePosition file line col = do - pos <- getPosition - setPosition - $ (flip setSourceName) file - $ (flip setSourceLine) line - $ (flip setSourceColumn) col - $ pos +module Web.Framework.Plzwrk.TH.HSX + ( HSXAttribute(..) + , HSX(..) + , parseHSX + ------------ for debugging + , endTag + , elementHSXBody + , attribute + , tag + , text + , haskellCodeNodes + , haskellTxtAttr + , haskellTxtNode + , haskellCodeNode + ) +where + +import Control.Applicative ( (<*) + , (*>) + , (<$>) + , (<$) + ) +import Control.Monad ( void ) +import qualified Control.Monad.Fail as MF +import Data.Char +import Data.List ( foldl' ) +import Text.Parsec +import Text.Parsec.String + +data HSXAttribute = HSXStringAttribute String + | HSXHaskellCodeAttribute String + | HSXHaskellTxtAttribute String deriving (Show, Eq) + +data HSX = HSXElement String [(String, HSXAttribute)] [HSX] + | HSXSelfClosingTag String [(String, HSXAttribute)] + | HSXHaskellCode String + | HSXHaskellCodeList String + | HSXHaskellText String + | HSXBody String + deriving (Show, Eq) + +hsx :: Parser HSX +hsx = tag + +tag = do + char '<' + ws + name <- many (letter <|> digit) + ws + attr <- many attribute + ws + close <- try (string "/>" <|> string ">") + if (length close) == 2 + then return (HSXSelfClosingTag name attr) + else do + elementBody <- many elementHSXBody + endTag name + ws + return (HSXElement name attr elementBody) + +elementHSXBody = + ws + *> ( try tag + <|> try haskellCodeNode + <|> try haskellCodeNodes + <|> try haskellTxtNode + <|> text + "A tag, a piece of code or some text" + ) + +endTag :: String -> Parser String +endTag str = string " string str <* char '>' + +text = HSXBody <$> many1 (noneOf "><") + +stringAttribute = do + char '"' + value <- many (noneOf ['"']) + char '"' + return $ HSXStringAttribute value + +haskellTxtAttr = do + string "#t{" + value <- manyTill anyChar (string "}#") + ws + return $ HSXHaskellTxtAttribute value + +makeBracketed cmd contain = do + let start = ("#" <> cmd <> "{") + let end = "}#" + string start + value <- manyTill anyChar (string end) + ws + return $ if (contain) then start <> value <> end else value + +haskellCodeAttr = do + value <- makeBracketed "c" False + return $ HSXHaskellCodeAttribute value + +haskellCodeNode :: Parser HSX +haskellCodeNode = do + value <- makeBracketed "e" False + return $ HSXHaskellCode value + +haskellCodeNodes :: Parser HSX +haskellCodeNodes = do + value <- makeBracketed "el" False + return $ HSXHaskellCodeList value + +haskellTxtNode :: Parser HSX +haskellTxtNode = do + value <- makeBracketed "t" False + return $ HSXHaskellText value + +attribute = do + name <- many (noneOf "= />") + ws + char '=' + ws + value <- stringAttribute <|> (try haskellCodeAttr) <|> haskellTxtAttr + ws + return (name, value) + +ws :: Parser () +ws = void $ many $ oneOf " \t\r\n" + +parseHSX :: MF.MonadFail m => (String, Int, Int) -> String -> m HSX +parseHSX (file, line, col) s = case runParser p () "" s of + Left err -> MF.fail $ show err + Right e -> return e + where + p = do + updatePosition file line col + ws + e <- hsx + ws + eof + return e + +updatePosition file line col = do + pos <- getPosition + setPosition + $ (flip setSourceName) file + $ (flip setSourceLine) line + $ (flip setSourceColumn) col + $ pos diff --git a/test/HSXSpec.hs b/test/HSXSpec.hs --- a/test/HSXSpec.hs +++ b/test/HSXSpec.hs @@ -1,68 +1,78 @@ -{-# LANGUAGE QuasiQuotes #-} - -module HSXSpec - ( hsxSpec - ) -where - -import Control.Monad -import qualified Data.HashMap.Strict as HM -import Control.Monad.Reader -import Data.IORef -import Test.Hspec -import Web.Framework.Plzwrk - -hsxSpec = describe "HSXParser" $ do - it "Parses simple hsx" $ do - let dom = [hsx|

Hello world!

|] - -- we use () for an empty state - - _elt_tag (dom ()) `shouldBe` "p" - _tn_text (((_elt_children (dom ())) !! 0) ()) `shouldBe` "Hello world!" - it "Parses hsx with an event listener" $ do - let dom = [hsx| -

- return $ x + 41)}#>Hello -

- |] - _elt_tag (dom 3) `shouldBe` "h1" - _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a" - let attrs = (_elt_attrs (((_elt_children (dom 1)) !! 0) 1)) - let clickAttr = (filter (\(x, _) -> x == "click") attrs) !! 0 - let mf (PwFunctionAttribute f) = f - let cf = mf ((snd clickAttr) 0) - res <- cf () 1 - res `shouldBe` 42 - it "Parses hsx with sub-hsx" $ do - let mylink = [hsx| return $ x + 41)}#>Hello|] - let dom = [hsx| -

- #e{mylink}# - #t{"hello world"}# -

- |] - _elt_tag (dom 3) `shouldBe` "h1" - _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a" - _tn_text (((_elt_children (dom 5)) !! 1) 3) `shouldBe` "hello world" - 1 `shouldBe` 1 - it "Parses hsx with a list of elements" $ do - let mylink = [hsx| return $ x + 41)}#>Hello|] - let dom = [hsx| -

- #el{take 10 $ repeat mylink}# - #t{"hello world"}# -

- |] - _elt_tag (dom 3) `shouldBe` "h1" - _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a" - _elt_tag (((_elt_children (dom 5)) !! 6) 3) `shouldBe` "a" - _tn_text (((_elt_children (dom 5)) !! 10) 3) `shouldBe` "hello world" - it "Parses hsx'" $ do - let mylink = [hsx| return $ x + 41)}#>Hello|] - let dom = (\st -> [hsx'| -

- #e{mylink}# -

- |]) - _elt_tag (dom 3) `shouldBe` "h1" - _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a" +{-# LANGUAGE QuasiQuotes #-} + +module HSXSpec + ( hsxSpec + ) +where + +import Control.Monad +import qualified Data.HashMap.Strict as HM +import Control.Monad.Reader +import Data.IORef +import Test.Hspec +import Web.Framework.Plzwrk + +hsxSpec = describe "HSXParser" $ do + it "Parses simple hsx" $ do + let dom = [hsx|

Hello world!

|] + -- we use () for an empty state + + _elt_tag (dom ()) `shouldBe` "p" + _tn_text (((_elt_children (dom ())) !! 0) ()) `shouldBe` "Hello world!" + it "Parses hsx with an event listener" $ do + let dom = [hsx| +

+ return $ x + 41)}#>Hello +

+ |] + _elt_tag (dom 3) `shouldBe` "h1" + _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a" + let attrs = (_elt_attrs (((_elt_children (dom 1)) !! 0) 1)) + let clickAttr = (filter (\(x, _) -> x == "click") attrs) !! 0 + let mf (PwFunctionAttribute f) = f + let cf = mf ((snd clickAttr) 0) + res <- cf () 1 + res `shouldBe` 42 + it "Parses hsx with sub-hsx" $ do + let mylink = [hsx| return $ x + 41)}#>Hello|] + let dom = [hsx| +

+ #e{mylink}# + #t{"hello world"}# +

+ |] + _elt_tag (dom 3) `shouldBe` "h1" + _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a" + _tn_text (((_elt_children (dom 5)) !! 1) 3) `shouldBe` "hello world" + 1 `shouldBe` 1 + it "Parses hsx with a list of elements" $ do + let mylink = [hsx| return $ x + 41)}#>Hello|] + let dom = [hsx| +

+ #el{take 10 $ repeat mylink}# + #t{"hello world"}# +

+ |] + _elt_tag (dom 3) `shouldBe` "h1" + _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a" + _elt_tag (((_elt_children (dom 5)) !! 6) 3) `shouldBe` "a" + _tn_text (((_elt_children (dom 5)) !! 10) 3) `shouldBe` "hello world" + it "Parses hsx mixing text and not text" $ do + let mylink = [hsx| return $ x + 41)}#>Hello|] + let dom = [hsx| +

+
Hello world
+

+ |] + _elt_tag (dom 3) `shouldBe` "h1" + _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "div" + _elt_tag ((_elt_children (((_elt_children (dom 5)) !! 0) 3) !! 1) 5) `shouldBe` "span" + it "Parses hsx'" $ do + let mylink = [hsx| return $ x + 41)}#>Hello|] + let dom = (\st -> [hsx'| +

+ #e{mylink}# +

+ |]) + _elt_tag (dom 3) `shouldBe` "h1" + _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a"