alpmestan/taggy
1
1
Fork 0
mirror of https://github.com/alpmestan/taggy.git synced 2024-09-11 15:05:40 +03:00
Code Issues Projects Releases Wiki Activity

store list of values in Hashmap, closes #17

Browse Source
This commit is contained in:
Mark Wotton 2016-05-04 15:15:39 -04:00
parent a9b080068f
commit e98c0032e6
2 changed files with 45 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
src/Text/Taggy/DOM.hs
View File

@ -5,7 +5,7 @@
-- License : BSD3
-- Maintainer : alpmestan@gmail.com
-- Stability : experimental
--
--
-- This module will help you represent
-- an HTML or XML document as a tree
-- and let you traverse it in whatever
@ -16,14 +16,14 @@
module Text.Taggy.DOM where
import Data.HashMap.Strict (HashMap)
import Data.Monoid ((<>))
import Data.Text (Text)
import Text.Taggy.Parser (taggyWith)
import Text.Taggy.Types
import Data.HashMap.Strict (HashMap)
import Data.Monoid ((<>))
import Data.Text (Text)
import Text.Taggy.Parser (taggyWith)
import Text.Taggy.Types
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy as LT
-- | An attribute name is just a 'Text' value
type AttrName = Text
@ -34,9 +34,9 @@ type AttrValue = Text
-- specified withing that tag, and all the children nodes
-- of that element. An 'Element' is basically anything but
-- \"raw\" content.
data Element =
data Element =
Element { eltName :: !Text -- ^ name of the element. e.g "a" for <a>
, eltAttrs :: !(HashMap AttrName AttrValue) -- ^ a (hash)map from attribute names to attribute values
, eltAttrs :: !(HashMap AttrName [AttrValue]) -- ^ a (hash)map from attribute names to attribute values
, eltChildren :: [Node] -- ^ children 'Node's
}
deriving (Eq, Show)
@ -76,10 +76,10 @@ domify [] = []
domify (TagOpen name attribs True : tags)
= NodeElement (Element name as []) : domify tags
where as = HM.fromListWith (\v1 v2 -> v1 <> " " <> v2)
where as = HM.fromListWith (\v1 v2 -> v1 <> v2)
. map attrToPair $ attribs
attrToPair (Attribute k v) = (k, v)
attrToPair (Attribute k v) = (k, [v])
domify (TagText txt : tags)
= NodeContent txt : domify tags
@ -88,10 +88,10 @@ domify (TagOpen name attribs False : tags)
= NodeElement (Element name as cs) : domify unusedTags
where (cs, unusedTags) = untilClosed name ([], tags)
as = HM.fromListWith (\v1 v2 -> v1 <> " " <> v2)
as = HM.fromListWith (\v1 v2 -> v1 <> v2)
. map attrToPair $ attribs
attrToPair (Attribute k v) = (k, v)
attrToPair (Attribute k v) = (k, [v])
domify (TagClose _ : tags) = domify tags
domify (TagComment _ : tags) = domify tags
@ -107,7 +107,7 @@ untilClosed name (cousins, TagClose n : ts)
| n == name = (cousins, ts)
| otherwise = untilClosed name ( cousins
, TagOpen n [] False
: TagClose n
: TagClose n
: ts )
untilClosed name (cousins, TagText t : ts)
@ -124,10 +124,10 @@ untilClosed name (cousins, TagOpen n as True : ts)
cousins'' = NodeElement elt : cousins'
in (cousins++cousins'', ts')
where as' = HM.fromListWith (\v1 v2 -> v1 <> " " <> v2)
where as' = HM.fromListWith (\v1 v2 -> v1 <> v2)
. map attrToPair $ as
attrToPair (Attribute k v) = (k, v)
attrToPair (Attribute k v) = (k, [v])
untilClosed name (cousins, TagOpen n as False : ts)
= let (insideNew, ts') = untilClosed n ([], ts)
@ -136,37 +136,36 @@ untilClosed name (cousins, TagOpen n as False : ts)
cousins'' = NodeElement elt : cousins'
in (cousins'', ts'')
where as' = HM.fromListWith (\v1 v2 -> v1 <> " " <> v2)
where as' = HM.fromListWith (\v1 v2 -> v1 <> v2)
. map attrToPair $ as
attrToPair (Attribute k v) = (k, v)
attrToPair (Attribute k v) = (k, [v])
untilClosed name (cousins, TagScript tago scr _ : ts)
= let (TagOpen n at _) = tago
(cousins', ts') = untilClosed name (cousins, ts)
cousins'' = NodeElement (Element n (at' at) [NodeContent scr]) : cousins'
in (cousins++cousins'', ts')
where at' at = HM.fromListWith (\v1 v2 -> v1 <> " " <> v2)
where at' at = HM.fromListWith (\v1 v2 -> v1 <> v2)
. map attrToPair $ at
attrToPair (Attribute k v) = (k, v)
attrToPair (Attribute k v) = (k, [v])
untilClosed name (cousins, TagStyle tago sty _ : ts)
= let (TagOpen n at _) = tago
(cousins', ts') = untilClosed name (cousins, ts)
cousins'' = NodeElement (Element n (at' at) [NodeContent sty]) : cousins'
in (cousins++cousins'', ts')
where at' at = HM.fromListWith (\v1 v2 -> v1 <> " " <> v2)
where at' at = HM.fromListWith (\v1 v2 -> v1 <> v2)
. map attrToPair $ at
attrToPair (Attribute k v) = (k, v)
attrToPair (Attribute k v) = (k, [v])
untilClosed _ (cs, []) = (cs, [])
convertText :: Text -> Node
convertText t = NodeContent t

37
src/Text/Taggy/Renderer.hs
View File

@ -1,29 +1,34 @@
{-# LANGUAGE LambdaCase, RecordWildCards, FlexibleInstances, UndecidableInstances, OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module : Text.Taggy.Renderer
-- Copyright : (c) 2014 Alp Mestanogullari, Vikram Verma
-- License : BSD3
-- Maintainer : alpmestan@gmail.com
-- Stability : experimental
--
--
-- Render a DOM tree (from "Text.Taggy.DOM")
-- using the excellent blaze markup rendering library.
module Text.Taggy.Renderer where
import Data.Foldable (foldMap)
import Data.HashMap.Strict (HashMap, foldlWithKey')
import Data.Monoid ((<>))
import Data.Text (Text, unpack)
import Data.Text.Encoding (encodeUtf8)
import Text.Blaze (Markup)
import Text.Blaze.Renderer.Text (renderMarkup)
import Text.Taggy.DOM (Element(..), Node(..))
import qualified Data.Text.Lazy as Lazy (Text)
import Text.Blaze.Internal (ChoiceString(..), StaticString(..), MarkupM(..))
import Data.Foldable (foldMap)
import Data.HashMap.Strict (HashMap, foldlWithKey')
import Data.List (foldl')
import Data.Monoid ((<>))
import Data.Text (Text, unpack)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy as Lazy (Text)
import Text.Blaze (Markup)
import Text.Blaze.Internal (ChoiceString (..), MarkupM (..),
StaticString (..))
import Text.Blaze.Renderer.Text (renderMarkup)
import Text.Taggy.DOM (Element (..), Node (..))
-- renderMarkup does entity conversion implicitly, and an override at the
-- constructor level is needed to control this; `PreEscaped (Text s)` is not
-- escaped, but a naked `Text s` is.
-- escaped, but a naked `Text s` is.
class AsMarkup a where
-- | If the first parameter is true, we align the constructors for entity
@ -55,9 +60,9 @@ class Renderable a where
instance AsMarkup a => Renderable a where
renderWith = fmap renderMarkup . toMarkup
toAttribute :: HashMap Text Text -> (Markup -> Markup)
toAttribute :: HashMap Text [Text] -> (Markup -> Markup)
toAttribute = flip $ foldlWithKey' toAttribute'
where toAttribute' html attr value = AddCustomAttribute (Text attr) (Text value) html
where toAttribute' html attr value = foldl' (\html' v -> AddCustomAttribute (Text attr) (Text v) html') html value
toStatic :: Text -> StaticString
toStatic text = StaticString (unpack text ++) (encodeUtf8 text) text