6 | Hello, world! 7 |
8 |9 | Goodbye! 10 |
11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Leif 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /src/Dom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, FlexibleInstances, TemplateHaskell#-} 2 | module Dom where 3 | 4 | import Data.Maybe (maybe) 5 | import Data.Monoid ((<>)) 6 | import Data.Foldable 7 | 8 | import qualified Data.HashMap.Strict as HM 9 | import qualified Data.Text as T 10 | 11 | import Data.HashSet 12 | import Control.Lens 13 | 14 | 15 | data NTree a = NTree { _root :: a, _children :: [NTree a] } 16 | deriving (Show,Eq) 17 | 18 | makeLenses ''NTree 19 | 20 | instance Functor NTree where 21 | fmap f (NTree n ns) = NTree (f n) $ fmap (fmap f) ns 22 | 23 | instance Foldable NTree where 24 | foldMap f (NTree n []) = f n 25 | foldMap f (NTree n ns) = f n <> foldMap (foldMap f) ns 26 | 27 | -- data specific to each node type 28 | data NodeType = Text T.Text 29 | | Element ElementData 30 | deriving (Show,Eq) 31 | 32 | type Node = NTree NodeType 33 | 34 | 35 | type AttrMap = HM.HashMap T.Text T.Text 36 | 37 | data ElementData = ElementData T.Text AttrMap 38 | deriving (Show,Eq) 39 | 40 | 41 | text :: T.Text -> Node 42 | text = flip NTree [] . Text 43 | 44 | elem :: T.Text -> AttrMap -> [Node] -> Node 45 | elem name atts = NTree (Element (ElementData name atts)) 46 | 47 | findAttr :: ElementData -> T.Text -> Maybe T.Text 48 | findAttr (ElementData _ m) k = HM.lookup k m 49 | 50 | findID :: ElementData -> Maybe T.Text 51 | findID = flip findAttr "id" 52 | 53 | classes :: ElementData -> HashSet T.Text 54 | classes = maybe empty (fromList . T.split (==' ')) . flip findAttr "class" -------------------------------------------------------------------------------- /hubert.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hubert.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hubert 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Leif 11 | maintainer: lgrele@gmail.com 12 | -- copyright: 13 | category: Web 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable hubert 19 | main-is: Main.hs 20 | other-modules: Dom, 21 | HTML.Parser, 22 | HTML.Parsec, 23 | CSS, 24 | Style, 25 | Layout 26 | 27 | -- other-extensions: 28 | build-depends: base >=4.7 && <5, 29 | unordered-containers >=0.2 && <0.3, 30 | mtl >= 2.2.1, 31 | text >= 1.1.0.0, 32 | parsec == 3.1.*, 33 | lens >= 4.6 34 | 35 | hs-source-dirs: src 36 | default-language: Haskell2010 37 | 38 | Test-Suite hunit-tests 39 | type: exitcode-stdio-1.0 40 | main-is: tests.hs 41 | other-modules: Dom, 42 | HTML.Parser, 43 | HTML.Parsec, 44 | CSS, 45 | Style, 46 | Layout, 47 | Painting 48 | build-depends: base >= 4.7 && < 5, 49 | unordered-containers >=0.2 && <0.3, 50 | mtl >= 2.2.1, 51 | text >= 1.1.0.0, 52 | HUnit >= 1.2.5.0, 53 | parsec == 3.1.*, 54 | vector >= 0.10.9.1, 55 | JuicyPixels >= 3.1.7.1, 56 | lens >= 4.6 57 | hs-source-dirs: tests, 58 | src 59 | default-language: Haskell2010 -------------------------------------------------------------------------------- /src/HTML/Parsec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts #-} 2 | module HTML.Parsec 3 | ( parseHtml, 4 | parseText, 5 | parseElement 6 | ) where 7 | 8 | import Control.Monad (liftM, void) 9 | import Control.Applicative ((<*)) 10 | 11 | import qualified Data.Text as T 12 | import Text.Parsec 13 | import Text.Parsec.Text 14 | 15 | import qualified Data.HashMap.Strict as HM 16 | 17 | import Dom 18 | 19 | parseHtml :: T.Text -> Either ParseError Node 20 | parseHtml s = case parse parseNodes "" s of 21 | Left err -> Left err 22 | Right nodes -> Right $ 23 | if length nodes == 1 24 | then head nodes 25 | else Dom.elem "html" HM.empty nodes 26 | 27 | 28 | parseNodes = spaces >> manyTill (spacesAfter parseNode) end 29 | where 30 | end = eof <|> void (try (string " parseText 34 | 35 | parseText = liftM (Dom.text . T.pack) $ many (noneOf "<") 36 | 37 | parseElement = do 38 | -- opening tag 39 | (tag, attrs) <- between (char '<') (char '>') tagData 40 | -- contents 41 | children <- parseNodes 42 | -- closing tag 43 | string $ tag ++ ">" -- "> manyTill parseChild end 48 | -- where 49 | -- end = eof <|> (try (string "> return ()) 50 | -- 51 | -- parseChild = spacesAfter parseNode 52 | 53 | 54 | tagData = do 55 | t <- tagName 56 | attrs <- attributes 57 | return (t,attrs) 58 | 59 | tagName = many1 alphaNum 60 | 61 | --this is safe because attribute will fail without consuming on '>'' 62 | attributes = liftM HM.fromList $ spaces >> many (spacesAfter attribute) 63 | 64 | attribute = do 65 | name <- tagName 66 | char '=' 67 | open <- char '\"' <|> char '\'' 68 | value <- manyTill anyChar (try $ char open) 69 | return (T.pack name, T.pack value) 70 | 71 | 72 | -- run parser p and then strip the trailing spaces, returning the result of p. 73 | spacesAfter p = p <* spaces 74 | -------------------------------------------------------------------------------- /src/Painting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Painting 3 | ( Canvas (..) 4 | , newCanvas 5 | , paint 6 | ) where 7 | 8 | import Data.Monoid ((<>),mempty) 9 | import Data.Word 10 | 11 | import qualified Data.Foldable as F 12 | import qualified Data.Vector as V 13 | import qualified Data.Text as T 14 | 15 | import Control.Lens 16 | 17 | import Dom 18 | import Layout 19 | import Style 20 | import CSS (Value(ColorValue), Color(..)) 21 | 22 | type DisplayList = V.Vector DisplayCommand 23 | 24 | data DisplayCommand = SolidColor Color Rect 25 | 26 | data Canvas = Canvas { pixels :: V.Vector Color 27 | , wdth :: Word 28 | , hght :: Word } 29 | 30 | 31 | paint :: LayoutBox -> Rect -> Canvas 32 | paint root bounds = let dlist = buildDisplayList root 33 | canvas = newCanvas w h 34 | w = fromInteger . floor $ bounds^.width 35 | h = fromInteger . floor $ bounds^.height 36 | in F.foldl' paintItem canvas dlist 37 | 38 | 39 | buildDisplayList :: LayoutBox -> DisplayList 40 | buildDisplayList = F.foldMap renderLayoutBox 41 | 42 | renderLayoutBox :: (Dimensions,BoxType) -> DisplayList 43 | renderLayoutBox box = renderBackgroud box <> renderBorders box 44 | 45 | renderBackgroud :: (Dimensions,BoxType) -> DisplayList 46 | renderBackgroud (dim,ty) = maybe mempty 47 | (return . flip SolidColor (borderBox dim)) (getColor ty "background") 48 | 49 | getColor :: BoxType -> T.Text -> Maybe Color 50 | getColor (BlockNode style) name = getColor' style name 51 | getColor (InlineNode style) name = getColor' style name 52 | getColor AnonymousBlock _ = Nothing 53 | 54 | getColor' style name = case value (NTree style []) name of 55 | Just (ColorValue (Color r g b a)) -> Just (Color r g b a) 56 | _ -> Nothing 57 | 58 | renderBorders :: (Dimensions,BoxType) -> DisplayList 59 | renderBorders (dim,ty) = maybe mempty renderBorders' (getColor ty "border-color") 60 | where 61 | renderBorders' color = V.fromList $ map (SolidColor color) [l, r, t, b] 62 | bbox = borderBox dim 63 | bdr = dim^.border 64 | 65 | l = bbox & width.~ bdr^.left 66 | 67 | r = bbox & x+~ bbox^.width - bdr^.right 68 | & width.~ bdr^.right 69 | 70 | t = bbox & height.~ bdr^.top 71 | 72 | b = bbox & y+~ bbox^.height - bdr^.bottom 73 | & height.~ bdr^.bottom 74 | 75 | newCanvas :: Word -> Word -> Canvas 76 | newCanvas w h = let white = Color 255 255 255 255 in 77 | Canvas (V.replicate (fromIntegral(w * h)) white) w h 78 | 79 | paintItem :: Canvas -> DisplayCommand -> Canvas 80 | paintItem cs (SolidColor color rect) = updateChunk cs (x0,x1) (y0,y1) color 81 | where 82 | x0 = clampInt 0 (w-1) (rect^.x) 83 | y0 = clampInt 0 (h-1) (rect^.y) 84 | x1 = clampInt 0 (w-1) (rect^.x + rect^.width - 1) 85 | y1 = clampInt 0 (h-1) (rect^.y + rect^.height - 1) 86 | w = asFloat $ wdth cs 87 | h = asFloat $ hght cs 88 | asFloat = fromInteger . toInteger 89 | 90 | 91 | 92 | -- this probably modifies the pixel vector in-place, if I'm reading the 93 | -- Data.Vector source correctly 94 | updateChunk :: Canvas -> (Integer,Integer) -> (Integer,Integer) -> Color -> Canvas 95 | updateChunk cs (x0,x1) (y0,y1) c = let pxs = V.update (pixels cs) chunk in 96 | cs{ pixels = pxs} 97 | where 98 | chunk = V.map (\a->(fromIntegral a,c)) indicies 99 | indicies = V.fromList [ y * toInteger (wdth cs) + x | x <- [x0..x1], y <- [y0..y1] ] 100 | 101 | 102 | clampInt :: Float -> Float -> Float -> Integer 103 | clampInt f c = floor . min c . max f 104 | -------------------------------------------------------------------------------- /src/Style.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Style where 3 | 4 | import Data.Maybe (mapMaybe, maybe, isJust, fromJust) 5 | import Data.Function (on) 6 | import Data.List (sortBy, find) 7 | 8 | import qualified Data.HashMap.Strict as HM 9 | import qualified Data.HashSet as HS 10 | import qualified Data.Text as T 11 | 12 | import Dom 13 | import CSS 14 | 15 | type PropertyMap = HM.HashMap T.Text Value 16 | 17 | -- instead of building a tree with references to the DOM, we'll 18 | -- just augment the DOM tree with PropertyMaps 19 | type StyledNode = NTree (NodeType,PropertyMap) 20 | 21 | -- this is kind of problematic, we end up computing Specificity twice 22 | -- but carrying the specificity around in the Rule might be weird too? 23 | -- TODO: look into changing this 24 | type MatchedRule = (Specificity, Rule) 25 | 26 | data Display = Inline | Block | DisplayNone 27 | deriving (Eq) 28 | 29 | -- if name exists, return its specified value 30 | value :: StyledNode -> T.Text -> Maybe Value 31 | value (NTree node _) name = HM.lookup name (snd node) 32 | 33 | -- return the specified value of the first property in ks to exist 34 | -- or def if no properties match 35 | lookup :: StyledNode -> [T.Text] -> Value -> Value 36 | lookup s ks def = maybe def (fromJust . value s) (find (isJust . value s) ks) 37 | 38 | -- look up the display value of a node 39 | display :: StyledNode -> Display 40 | display n = case value n "display" of 41 | Just (Keyword "block") -> Block 42 | Just (Keyword "none") -> DisplayNone 43 | _ -> Inline 44 | 45 | -- check if a selector matches an element 46 | matches :: ElementData -> Selector -> Bool 47 | matches e sl@Simple{} = matchSimple e sl 48 | 49 | 50 | -- matchSimple returns False if any selector field that exists 51 | -- does not match the given element 52 | matchSimple :: ElementData -> Selector -> Bool 53 | matchSimple e (Simple Nothing Nothing c) = matchClasses e c 54 | matchSimple e (Simple (Just n) Nothing c) = matchNames e n 55 | && matchClasses e c 56 | matchSimple e (Simple Nothing (Just i) c) = matchId e i 57 | && matchClasses e c 58 | matchSimple e (Simple (Just n) (Just i) c) = matchNames e n 59 | && matchId e i 60 | && matchClasses e c 61 | 62 | matchNames (ElementData nm _) n = n == nm 63 | 64 | matchId e i = findID e == Just i 65 | 66 | matchClasses e [] = True 67 | matchClasses e c = all (flip HS.member (classes e)) c 68 | 69 | -- matchSimple e@(ElementData nm _) (Simple n i c) = 70 | -- let x = fmap (==nm) n 71 | -- y = if i == Nothing then Nothing else Just $ i == (findID e) 72 | -- z = if not $ null c then all (flip HS.member (classes e)) c else True 73 | -- in case (x,y,z) of 74 | -- (Nothing, Nothing, b3) -> b3 75 | -- (Nothing, Just b2, b3) -> b2 && b3 76 | -- (Just b1, Nothing, b3) -> b1 && b3 77 | -- (Just b1, Just b2, b3) -> b1 && b2 && b3 78 | 79 | 80 | -- find the first rule that matches the given element 81 | matchRule :: ElementData -> Rule -> Maybe MatchedRule 82 | matchRule e r@(Rule selectors _) = do 83 | s <- find (matches e) selectors 84 | return (spec s, r) 85 | 86 | 87 | -- get all of the rules from a stylesheet that match the given element 88 | matchingRules :: ElementData -> Stylesheet -> [MatchedRule] 89 | matchingRules e (Stylesheet rules) = mapMaybe (matchRule e) rules 90 | 91 | 92 | -- Build a map of all the properties attached to an Element 93 | specifiedValues :: ElementData -> Stylesheet -> PropertyMap 94 | specifiedValues e s = HM.fromList $ concatMap expand rules 95 | where 96 | rules = sortBy (compare `on` fst) $ matchingRules e s 97 | expand (_,Rule _ ds) = map (\(Declaration n v) -> (n,v)) ds 98 | 99 | 100 | -- traverse the DOM, attaching PropertyMaps to each Node to 101 | -- create a styled tree 102 | styleTree :: Node -> Stylesheet -> StyledNode 103 | styleTree root stylesheet = fmap style root 104 | where 105 | style e@(Element e') = (e, specifiedValues e' stylesheet) 106 | style t@(Text _) = (t, HM.empty) -------------------------------------------------------------------------------- /src/HTML/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module HTML.Parser 3 | ( Parser(..), 4 | parseHtml, 5 | parseText, 6 | parseElement, 7 | runParserS 8 | ) where 9 | 10 | import Data.Char (isAlphaNum, isSpace) 11 | import Control.Monad (liftM, unless) 12 | 13 | import Control.Monad.State.Lazy (StateT(..), evalState, get, put) 14 | import Control.Monad.Except (ExceptT(..), runExceptT, throwError) 15 | import Control.Monad.Identity 16 | 17 | import qualified Data.HashMap.Strict as HM 18 | import qualified Data.Text as T 19 | 20 | import Dom 21 | 22 | data Parser = Parser T.Text 23 | 24 | type ParserS = ExceptT T.Text (StateT Parser Identity) 25 | 26 | 27 | runParserS p = evalState (runExceptT p) 28 | 29 | nextchr :: Parser -> Char 30 | nextchr (Parser s) = T.head s -- errors if called when string is empty 31 | 32 | startsWith :: Parser -> T.Text -> Bool 33 | startsWith (Parser input) s = s `T.isPrefixOf` input 34 | 35 | eof :: Parser -> Bool 36 | eof (Parser input) = T.null input 37 | 38 | 39 | consumeChar :: ParserS Char 40 | consumeChar = do 41 | (Parser inp) <- get 42 | case T.uncons inp of 43 | Nothing -> throwError "ERROR: unexpectedly reached end of file" 44 | Just (c,inp') -> do 45 | put (Parser inp') 46 | return c 47 | 48 | consumeWhile :: (Char -> Bool) -> ParserS T.Text 49 | consumeWhile f = do 50 | Parser input <- get 51 | let (s,input') = T.span f input 52 | put $ Parser input' 53 | return s 54 | 55 | consumeWhitespace :: ParserS T.Text 56 | consumeWhitespace = consumeWhile isSpace 57 | 58 | 59 | -- use this to mimic robinson's (improper, soon to be depriciated) 60 | -- use of assert 61 | assert :: T.Text -> Bool -> ParserS () 62 | assert s b = unless b $ throwError s 63 | 64 | 65 | parseTagName :: ParserS T.Text 66 | parseTagName = consumeWhile isAlphaNum 67 | 68 | 69 | parseNode :: ParserS Node 70 | parseNode = do 71 | p <- get 72 | if nextchr p == '<' then parseElement else parseText 73 | 74 | parseText :: ParserS Node 75 | parseText = liftM Dom.text $ consumeWhile (/='<') 76 | 77 | parseElement :: ParserS Node 78 | parseElement = do 79 | -- open tag 80 | consumeChar >>= assert "missing < in open tag" . (=='<') 81 | tag <- parseTagName 82 | attrs <- parseAttributes 83 | consumeChar >>= assert "missing > in open tag" . (=='>') 84 | -- contents 85 | children <- parseNodes 86 | --end tag 87 | consumeChar >>= assert "missing < in close tag" . (=='<') 88 | consumeChar >>= assert "missing / in close tag" . (=='/') 89 | parseTagName >>= assert "end tag doesn't match start tag" . (==tag) 90 | consumeChar >>= assert "missing > in close tag" . (=='>') 91 | 92 | return $ Dom.elem tag attrs children 93 | 94 | 95 | parseAttr :: ParserS (T.Text, T.Text) 96 | parseAttr = do 97 | name <- parseTagName 98 | consumeChar >>= assert "missing =" . (=='=') 99 | value <- parseAttrValue 100 | return (name,value) 101 | 102 | parseAttrValue :: ParserS T.Text 103 | parseAttrValue = do 104 | open <- consumeChar 105 | assert "invalid open" (open == '\"' || open == '\'') 106 | val <- consumeWhile (/=open) 107 | consumeChar >>= assert "invalid close" . (==open) 108 | return val 109 | 110 | parseAttributes :: ParserS AttrMap 111 | parseAttributes = parseAttributes' HM.empty 112 | where 113 | parseAttributes' attrs = do 114 | consumeWhitespace 115 | p <- get 116 | if nextchr p == '>' then return attrs 117 | else do 118 | (name,val) <- parseAttr 119 | parseAttributes' $ HM.insert name val attrs 120 | 121 | 122 | parseNodes :: ParserS [Node] 123 | parseNodes = parseNodes' [] 124 | where 125 | parseNodes' nodes = do 126 | consumeWhitespace 127 | p <- get 128 | if eof p || p `startsWith` ">= parseNodes' . (nodes++) . (:[]) --slow for big DOM 131 | 132 | 133 | parseHtml :: T.Text -> Either T.Text Node 134 | parseHtml s = case runParserS parseNodes (Parser s) of 135 | Left err -> Left err 136 | Right nodes -> Right $ 137 | if length nodes == 1 138 | then head nodes 139 | else Dom.elem "html" HM.empty nodes 140 | -------------------------------------------------------------------------------- /src/CSS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} 2 | module CSS 3 | ( Stylesheet(..) 4 | , Rule(..) 5 | , Selector(..) 6 | , Declaration(..) 7 | , Value(..) 8 | , Color(..) 9 | , Unit(..) 10 | , Specificity(..) 11 | , parseCSS 12 | , selectors 13 | , declarations 14 | , spec 15 | , toPx 16 | ) where 17 | 18 | import Prelude hiding (id) 19 | 20 | import Data.Word (Word(..), Word8(..)) 21 | import Data.List (sortBy) 22 | import Data.Maybe (maybe) 23 | import Numeric (readFloat, readHex) 24 | import Control.Monad (void) 25 | import Control.Applicative ((<*), (*>), (<$>), (<*>)) 26 | 27 | import Text.Parsec 28 | import Text.Parsec.Text 29 | 30 | import qualified Data.Text as T 31 | 32 | data Stylesheet = Stylesheet [Rule] 33 | deriving (Show, Eq) 34 | 35 | data Rule = Rule [Selector] [Declaration] 36 | deriving (Show, Eq) 37 | 38 | -- only handle simple selectors for now 39 | data Selector = Simple (Maybe T.Text) (Maybe T.Text) [T.Text] 40 | deriving (Show, Eq) 41 | 42 | data Declaration = Declaration T.Text Value 43 | deriving (Show, Eq) 44 | 45 | data Value = Keyword T.Text 46 | | ColorValue Color 47 | | Length Float Unit 48 | deriving (Show, Eq) 49 | 50 | data Color = Color Word8 Word8 Word8 Word8 51 | deriving (Show, Eq) 52 | 53 | data Unit = Px --only Px for now 54 | deriving (Show, Eq) 55 | 56 | toPx :: Value -> Float 57 | toPx (Length len Px) = len 58 | toPx _ = 0 59 | 60 | type Specificity = (Word,Word,Word) 61 | 62 | -- compute the specificity of a Selector 63 | spec :: Selector -> Specificity 64 | spec (Simple name id cls) = (maybeLen id, fromIntegral $ length cls, maybeLen name) 65 | where maybeLen = fromIntegral . maybe 0 T.length 66 | 67 | 68 | -- an empty selector 69 | nilS = Simple Nothing Nothing [] 70 | 71 | 72 | -- parse an entire CSS document into a Stylesheet 73 | parseCSS :: T.Text -> Either ParseError Stylesheet 74 | parseCSS css = case runParser rules nilS "" css of 75 | Left err -> Left err 76 | Right rs -> Right (Stylesheet rs) 77 | 78 | 79 | 80 | rules = spaces >> manyTill (rule <* spaces) eof 81 | 82 | 83 | -- rule = do 84 | -- s <- selectors 85 | -- d <- declarations 86 | -- return $ Rule s d 87 | 88 | rule = Rule <$> selectors <*> declarations 89 | 90 | 91 | selectors = sortBy comp <$> sepBy1 (selector <* spaces) comma 92 | where comma = char ',' <* spaces 93 | comp a b = spec a `compare` spec b 94 | 95 | 96 | -- parse a simple selector 97 | selector = do 98 | putState nilS 99 | manyUnless (id <|> cls <|> univ <|> name) eof 100 | getState 101 | 102 | 103 | -- selector id 104 | id = do 105 | char '#' 106 | i <- identifier 107 | modifyState (\(Simple n _ cs) -> Simple n (Just i) cs) 108 | 109 | -- selector class 110 | cls = do 111 | char '.' 112 | c <- identifier 113 | modifyState (\(Simple n i cs) -> Simple n i (cs++[c])) 114 | 115 | -- universal selector 116 | univ = void (char '*') 117 | 118 | -- selector name 119 | name = do 120 | n' <- validId 121 | n <- identifier 122 | let nm = n' `T.cons` n 123 | modifyState (\(Simple _ i cs) -> Simple (Just nm) i cs) 124 | 125 | 126 | declarations = do 127 | char '{' 128 | spaces *> manyTill (declaration <* spaces) (char '}') 129 | 130 | 131 | declaration = do 132 | n <- identifier 133 | spaces >> char ':' >> spaces 134 | v <- value 135 | spaces >> char ';' 136 | return $ Declaration n v 137 | 138 | 139 | value = len <|> color <|> keyword 140 | 141 | -- len = do 142 | -- f <- float 143 | -- u <- unit 144 | -- return $ Length f u 145 | len = Length <$> float <*> unit 146 | 147 | -- parse a floating point number 148 | float :: Stream s m Char => ParsecT s u m Float 149 | float = (fst . head . readFloat) <$> many (digit <|> char '.') 150 | 151 | -- parse the unit type in a Value 152 | -- currently only Px is supported 153 | unit = do 154 | char 'p' <|> char 'P' 155 | char 'x' <|> char 'X' 156 | return Px 157 | 158 | 159 | color = do 160 | char '#' 161 | cs <- count 3 (count 2 hexDigit) 162 | let [r,g,b] = map (fst . head . readHex) cs 163 | return $ ColorValue (Color r g b 255) 164 | 165 | keyword = Keyword <$> identifier 166 | 167 | identifier = T.pack <$> many validId 168 | 169 | validId = alphaNum <|> char '-' <|> char '_' 170 | 171 | -- manyTill, but the terminal parser is optional 172 | manyUnless p end = many (notFollowedBy end *> p) 173 | -------------------------------------------------------------------------------- /tests/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Prelude hiding (elem) 5 | import Data.Either (either) 6 | import Control.Monad (liftM) 7 | 8 | import Test.HUnit 9 | 10 | import Text.Parsec hiding (parseTest) 11 | import Text.Parsec.Text 12 | 13 | import Data.Maybe 14 | 15 | import qualified Data.Text as T 16 | import qualified Data.HashMap.Strict as HM 17 | import qualified Data.Vector as V 18 | 19 | 20 | import Codec.Picture 21 | import Codec.Picture.Types 22 | 23 | import qualified HTML.Parser as PR 24 | import qualified HTML.Parsec as PS 25 | 26 | import Control.Lens 27 | 28 | import Dom 29 | import CSS 30 | import Style 31 | import Layout 32 | import Painting 33 | 34 | 35 | main = runTestTT tests 36 | 37 | tests = TestList [TestLabel "ParserS html" htmlPR, 38 | TestLabel "ParserS text" textPR, 39 | TestLabel "ParserS elem" elemPR, 40 | TestLabel "Parsec html" htmlPS, 41 | TestLabel "Parsec text" textPS, 42 | TestLabel "Parsec elem" elemPS, 43 | TestLabel "CSS sheet" testCss, 44 | TestLabel "Apply styles" testStyle, 45 | TestLabel "Paint blocks" testPaint ] 46 | 47 | 48 | --------------------------- PARSER_S TESTS ------------------------------ 49 | 50 | parsePR p i = PR.runParserS p (PR.Parser i) 51 | 52 | htmlPR = parseTest "for valid html" dom $ PR.parseHtml html 53 | 54 | 55 | textPR = parseTest "for valid text" testText $ parsePR PR.parseText "candygram" 56 | 57 | 58 | elemPR = parseTest "for valid elem" testElem $ 59 | parsePR PR.parseElement "sup
" 60 | 61 | 62 | ---------------------------- PARSEC TESTS ------------------------------ 63 | 64 | 65 | htmlPS = parseTest "for valid html" dom $ PS.parseHtml html 66 | 67 | 68 | textPS = parseTest "for valid text" testText $ 69 | parse PS.parseText "" $ T.pack "candygram" 70 | 71 | 72 | elemPS = parseTest "for valid elem" testElem $ 73 | parse PS.parseElement "" $ T.pack "sup
" 74 | 75 | 76 | ------------------------------ CSS TESTS ---------------------------- 77 | 78 | testCss = parseTest "for valid css" sheet $ parseCSS css 79 | 80 | ------------------------------ STYLE TESTS -------------------------- 81 | 82 | testStyle = TestCase $ assertEqual "styletree" styletree $ styleTree dom css2 83 | 84 | ----------------------------- PAINT TESTS --------------------------- 85 | 86 | testPaint = TestCase $ do 87 | testpng <- readPng "tests/rainbow.png" 88 | either (\_->assertFailure "missing png image") 89 | (compareImage paintpng) 90 | testpng 91 | 92 | compareImage (Left e) _ = assertFailure $ T.unpack e 93 | compareImage (Right i1) (ImageRGB8 i2) = do 94 | assertEqual "height" (imageHeight i1) (imageHeight i2) 95 | assertEqual "width" (imageWidth i1) (imageWidth i2) 96 | assertEqual "pixels" (imageData i1) (imageData i2) 97 | 98 | ----------------------------- SHARED -------------------------------- 99 | 100 | 101 | -- generic test: given an expected value and an actual value, check that the actual 102 | -- value is not an error message, then compare it to the expected value 103 | parseTest msg e = TestCase . either (assertFailure . show) (assertEqual msg e) 104 | 105 | testText = text "candygram" 106 | testElem = elem "p" (HM.singleton "ham" "doctor") [text "sup"] 107 | 108 | -- a small test html page 109 | html = "\n\ 110 | \ \n\ 111 | \\n\ 114 | \ Hello, world!\n\ 115 | \
\n\ 116 | \\n\ 117 | \ Goodbye!\n\ 118 | \
\n\ 119 | \" 120 | 121 | -- the expected result of parsing the test page 122 | dom = elem "html" HM.empty [head,p1,p2] 123 | where 124 | head = elem "head" HM.empty [title] 125 | title = elem "title" HM.empty [text "Test"] 126 | p1 = elem "p" (HM.singleton "class" "inner") [hello, span] 127 | hello = text "Hello, " 128 | span = elem "span" (HM.singleton "id" "name") [text "world!"] 129 | p2 = elem "p" (HM.singleton "class" "inner") [text "Goodbye!\n "] 130 | 131 | 132 | 133 | css = "h1, h2, h3 { margin: auto; color: #cc0000; }\n\ 134 | \div.note { margin-bottom: 20px; padding: 10px; }\n\ 135 | \#answer { display: none; }" 136 | 137 | sheet = Stylesheet [ Rule [ Simple (Just "h1") Nothing [] 138 | , Simple (Just "h2") Nothing [] 139 | , Simple (Just "h3") Nothing [] ] 140 | [ Declaration "margin" (Keyword "auto") 141 | , Declaration "color" (ColorValue(Color 204 0 0 255)) ] 142 | , Rule [ Simple (Just "div") Nothing ["note"] ] 143 | [ Declaration "margin-bottom" (Length 20 Px) 144 | , Declaration "padding" (Length 10 Px) ] 145 | , Rule [ Simple Nothing (Just "answer") [] ] 146 | [ Declaration "display" (Keyword "none") ] ] 147 | 148 | 149 | css2 = Stylesheet [ Rule [ Simple (Just "head") Nothing [] ] 150 | [ Declaration "margin" (Keyword "auto") 151 | , Declaration "color" (ColorValue(Color 0 0 0 255)) ] 152 | , Rule [ Simple (Just "p") Nothing ["inner"] ] 153 | [ Declaration "padding" (Length 17 Px) ] ] 154 | 155 | styletree = NTree (Element (ElementData "html" empt),empt) [head,p1,p2] 156 | where 157 | head = NTree (Element (ElementData "head" empt),rule1) [title] 158 | title = NTree (Element (ElementData "title" empt),empt) [test'] 159 | test' = NTree (Text "Test",empt) [] 160 | p1 = NTree (Element (ElementData "p" (HM.singleton "class" "inner")),rule2) [hello,span] 161 | hello = NTree (Text "Hello, ",empt) [] 162 | span = NTree (Element (ElementData "span" (HM.singleton "id" "name")),empt) [world] 163 | world = NTree (Text "world!",empt) [] 164 | p2 = NTree (Element (ElementData "p" (HM.singleton "class" "inner")),rule2) [goodbye] 165 | goodbye = NTree (Text "Goodbye!\n ",empt) [] 166 | empt = HM.empty 167 | rule1 = HM.fromList [("margin",Keyword "auto"),("color",ColorValue (Color 0 0 0 255))] 168 | rule2 = HM.singleton "padding" (Length 17 Px) 169 | 170 | contBlock = defaultDim & content.width.~800 & content.height.~168 171 | 172 | paintpng = paintpng' s d 173 | where 174 | (Right d) = PS.parseHtml pnghtml 175 | (Right s) = parseCSS pngcss 176 | paintpng' s d = do 177 | let st = styleTree d s 178 | lyt <- layoutTree st contBlock 179 | let vec = pixels $ paint lyt (contBlock^.content) 180 | return $ generateImage (\x y-> c2px $ vec V.! (x + (y * 800))) 800 168 181 | c2px (Color r g b _) = PixelRGB8 r g b 182 | 183 | pnghtml = "