packages feed

plzwrk 0.0.0.7 → 0.0.0.8

raw patch · 4 files changed

+229/−203 lines, 4 files

Files

ChangeLog.md view
@@ -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.
plzwrk.cabal view
@@ -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 <https://github.com/meeshkan/plzwrk#readme>
src/Web/Framework/Plzwrk/TH/HSX.hs view
@@ -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
test/HSXSpec.hs view
@@ -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|<p>Hello world!</p>|]-    -- 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|-            <h1 id="foo" style="position:absolute">-                <a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>-            </h1>-        |]-    _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|<a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>|]-    let dom = [hsx|-            <h1 id="foo" style="position:absolute">-                #e{mylink}#-                #t{"hello world"}#-            </h1>-        |]-    _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|<a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>|]-    let dom = [hsx|-            <h1 id="foo" style="position:absolute">-                #el{take 10 $ repeat mylink}#-                #t{"hello world"}#-            </h1>-        |]-    _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|<a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>|]-    let dom = (\st -> [hsx'|-            <h1 id="foo" style=#t{"position:absolute"}#>-                #e{mylink}#-            </h1>-        |])-    _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|<p>Hello world!</p>|]
+    -- 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|
+            <h1 id="foo" style="position:absolute">
+                <a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>
+            </h1>
+        |]
+    _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|<a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>|]
+    let dom = [hsx|
+            <h1 id="foo" style="position:absolute">
+                #e{mylink}#
+                #t{"hello world"}#
+            </h1>
+        |]
+    _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|<a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>|]
+    let dom = [hsx|
+            <h1 id="foo" style="position:absolute">
+                #el{take 10 $ repeat mylink}#
+                #t{"hello world"}#
+            </h1>
+        |]
+    _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|<a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>|]
+    let dom = [hsx|
+            <h1 id="foo" style="position:absolute">
+                <div>Hello <span>world</span> </div>
+            </h1>
+        |]
+    _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|<a click=#c{(\_ x -> return $ x + 41)}#>Hello</a>|]
+    let dom = (\st -> [hsx'|
+            <h1 id="foo" style=#t{"position:absolute"}#>
+                #e{mylink}#
+            </h1>
+        |])
+    _elt_tag (dom 3) `shouldBe` "h1"
+    _elt_tag (((_elt_children (dom 5)) !! 0) 3) `shouldBe` "a"