miso-from-html (empty) → 0.1.0.0
raw patch · 5 files changed
+442/−0 lines, 5 filesdep +attoparsecdep +basedep +bytestring
Dependencies added: attoparsec, base, bytestring, containers, pretty-simple, text
Files
- LICENSE +10/−0
- Main.hs +250/−0
- README.md +67/−0
- index.html +67/−0
- miso-from-html.cabal +48/−0
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2016-2020, David M. Johnson+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# Language StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Main where++import Control.Applicative++import Data.Attoparsec.Text+import Data.Char+import Data.List hiding (takeWhile)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Prelude hiding (takeWhile)+import System.Exit+import Text.Pretty.Simple++data HTML+ = Branch TagName [ Attr ] [ HTML ]+ | Leaf Text+ deriving (Eq)++newtype CSS = CSS (Map Text Text)+ deriving (Eq)+ deriving newtype (Monoid, Semigroup)++instance Show CSS where+ show (CSS hmap) =+ mconcat+ [ "M.fromList [ "+ , intercalate "," (go <$> M.assocs hmap)+ , " ]"+ ]+ where+ go (k,v) = "(" <> "\"" <>+ T.unpack k <> "\" ," <> "\"" <>+ T.unpack v <> "\" )"++data Attr = Attr Text (Maybe Text)+ deriving (Eq)++instance Show HTML where+ show (Leaf x) = "\"" <> T.unpack x <> "\""+ show (Branch t as cs) =+ mconcat $+ [ T.unpack t+ , "_ "+ , show as+ ] ++ [ show cs | not (isEmpty t) ]++instance Show Attr where+ show (Attr "style" (Just v)) =+ mconcat+ [ "style_ $ "+ , T.unpack v+ ]+ show (Attr k (Just v)) =+ mconcat+ [ T.unpack k+ , "_ "+ , "\""+ , T.unpack v+ , "\""+ ]+ show (Attr k Nothing) =+ mconcat+ [ "textProp \""+ , T.unpack k+ , "\" \"\""+ ]++type TagName = Text++tag :: Parser (TagName, [Attr])+tag = do+ _ <- char '<'+ t <- takeWhile1 isAlphaNum+ _ <- char '>'+ pure (t, [])++tagWithAttrs :: Parser (TagName, [Attr])+tagWithAttrs = do+ _ <- char '<'+ t <- takeWhile1 (/=' ')+ _ <- char ' '+ as <- attrs `sepBy` (char ' ')+ skipSpace+ _ <- char '>'+ pure (t, as)++attrs :: Parser Attr+attrs = kvAttr <|> attr+ where+ predicate x = isAlpha x || x == '-'+ kvAttr = Attr <$> key <*> do Just <$> value+ attr = flip Attr Nothing <$> justKey+ justKey = takeWhile1 predicate+ key = do+ k <- takeWhile1 predicate+ _ <- char '='+ pure k+ value = do+ _ <- char '"'+ v <- takeWhile (/= '"')+ _ <- char '"'+ pure v++children :: Parser [HTML]+children = many htmlOrLeaf++htmlOrLeaf :: Parser HTML+htmlOrLeaf = html <|> leaf++leaf :: Parser HTML+leaf = Leaf <$> do+ strip . T.filter (/='\n') <$>+ takeWhile1 (/='<')+ where+ strip = T.reverse+ . T.dropWhile (==' ')+ . T.reverse+ . T.dropWhile (==' ')++dropFluff :: Parser ()+dropFluff = do+ _ <- takeWhile (`elem` ("\n " :: String))+ pure ()++html :: Parser HTML+html = do+ (openTag, as) <-+ tag <|> tagWithAttrs+ dropFluff+ cs <-+ if isEmpty openTag+ then pure []+ else do+ cs <- children+ closeTag+ pure cs+ dropFluff+ let hasStyle (Attr k _) = k == "style"+ pure $ case listToMaybe (filter hasStyle as) of+ Just (Attr key (Just cssText)) -> do+ let parsedCss = T.pack $ show (parseCss cssText)+ newAttr = Attr key (Just parsedCss)+ oldAttrs = filter (not . hasStyle) as+ Branch openTag (newAttr : oldAttrs) cs+ _ ->+ Branch openTag as cs++parseCss :: Text -> CSS+parseCss cssText = CSS cssMap+ where+ cssMap+ = M.fromList+ [ (k,v)+ | [k,v] <- T.splitOn ":" <$> T.splitOn ";" cssText+ ]++isEmpty :: Text -> Bool+isEmpty =+ flip elem+ [ "img"+ , "hr"+ , "meta"+ , "link"+ , "br"+ ]++closeTag :: Parser ()+closeTag = do+ _ <- string "</"+ _ <- takeWhile1 isAlphaNum+ _ <- char '>'+ pure ()++main :: IO ()+main = do+ file <- removeComments <$> T.getContents+ case parseOnly html file of+ Right r ->+ pPrint r+ Left e -> do+ print e+ exitFailure++-- | Layered lexer+data Mode+ = InComment+ | Normal+ deriving (Show, Eq)++-- | Remove HTML comments using a layered lexer+--+-- @+-- > removeComments "<a><!-- hey --></a>"+-- > <a></a>+-- @+--+removeComments :: Text -> Text+removeComments = go Normal Nothing+ where+ go Normal Nothing txt =+ case T.uncons txt of+ Nothing ->+ mempty+ Just (c, next) ->+ T.singleton c <>+ go Normal (Just c) next+ go Normal (Just _) txt =+ case T.uncons txt of+ Nothing ->+ mempty+ Just (c,next) ->+ case T.uncons next of+ Just (c',next') ->+ if [c,c'] == "<!"+ then+ go InComment (Just c') next'+ else+ T.singleton c <>+ go Normal (Just c) next+ Nothing ->+ T.singleton c <>+ go Normal (Just c) next+ go InComment Nothing txt =+ case T.uncons txt of+ Nothing ->+ error "Comment not terminated"+ Just (c,next) ->+ go InComment (Just c) next+ go InComment (Just prev) txt =+ case T.uncons txt of+ Nothing ->+ error "Comment not terminated"+ Just (c,next) ->+ if [prev,c] == "->"+ then go Normal (Just c) next+ else go InComment (Just c) next++
+ README.md view
@@ -0,0 +1,67 @@+miso-from-html+===================+++[](https://github.com/dmjio/miso-from-html/blob/master/stripe-haskell/LICENSE)+[](https://travis-ci.org/dmjio/miso-from-html)++Convert HTML into [miso](https://github.com/dmjio/miso) `View` syntax.++[](https://asciinema.org/a/MHZ5r4muWitBshkXhjtLHUBQQ)++### Features+ - Strips comments+ - Pretty prints style tags as a Haskell `Map` from `Data.Map`++### Usage++Given some HTML++```html+<nav class="navbar" role="navigation">+ <div class="navbar-brand">+ <a class="navbar-item" href="https://bulma.io">+ <img src="https://bulma.io/images/bulma-logo.png" width="112" height="28">+ <a>ok<p>hey</p></a>+ </a>+ </div>+</nav>+```++Convert it to [miso](https://github.com/dmjio/miso) `View` syntax.++```bash+$ cabal run miso-from-html < index.html+```++Result++```haskell+nav_+ [ class_ "navbar"+ , role_ "navigation"+ ]+ [ div_ [ class_ "navbar-brand" ]+ [ a_+ [ class_ "navbar-item"+ , href_ "https://bulma.io"+ ]+ [ img_+ [ src_ "https://bulma.io/images/bulma-logo.png"+ , width_ "112"+ , height_ "28"+ ]+ , a_ []+ [ "ok"+ , p_ [][ "hey" ]+ ]+ ]+ ]+ ]+```++### Test++```bash+$ nix-shell --run 'runghc Main.hs < index.html'+```
+ index.html view
@@ -0,0 +1,67 @@+<html lang="en">+ <head></head>+ <body>+ <div>+ <a href="http://github.com/dmjio/miso" data-ribbon="Fork me on GitHub" title="Fork me on GitHub" rel="noopener" class="github-fork-ribbon left-top fixed" target="blank">Fork me on GitHub</a>+ <section class="hero is-medium is-primary is-bold has-text-centered">+ <div class="hero-head">+ <header class="nav">+ <div class="container">+ <div class="nav-left"><a class="nav-item"></a></div>+ <span class="nav-toggle "><span></span><span></span><span></span></span>+ <div class="nav-right nav-menu ">+ <a href="/" class="nav-item is-active">Home</a><a href="/examples" class="nav-item ">Examples</a><a href="/docs" class="nav-item ">Docs</a> <a href="/community" class="nav-item ">Community</a> </div>+ </div>+ </header>+ </div>+ <div class="hero-body">+ <div class="container">+ <div class="animated fadeIn">+ <a href="https://github.com/dmjio/miso"><img width="100" src="https://camo.githubusercontent.com/d6641458f09e24e8fef783de8278886949085960/68747470733a2f2f656d6f6a6970656469612d75732e73332e616d617a6f6e6177732e636f6d2f7468756d62732f3234302f6170706c652f39362f737465616d696e672d626f776c5f31663335632e706e67" class="animated bounceInDown" alt="miso logo"></img></a>+ <h1 style="font-size:82px;font-weight:100;" class="title animated pulse">miso</h1>+ <h2 class="subtitle animated pulse">A tasty <a href="https://www.haskell.org/" rel="noopener" target="_blank"><strong>Haskell</strong></a> front-end framework</h2>+ </div>+ </div>+ </div>+ </section>+ <section class="hero">+ <div class="hero-body">+ <div class="container">+ <nav class="columns">+ <a href="https://rawgit.com/krausest/js-framework-benchmark/master/webdriver-ts-results/table.html" rel="noopener" class="column has-text-centered" target="_blank">+ <span class="icon is-large"><i class="fa fa-flash"></i></span>+ <p class="title is-4"><strong>Fast</strong></p>+ <p class="subtitle">Virtual DOM diffing algorithm</p>+ </a>+ <a href="https://en.wikipedia.org/wiki/Isomorphic_JavaScript" rel="noopener" class="column has-text-centered" target="_blank">+ <span class="icon is-large"><i class="fa fa-refresh"></i></span>+ <p class="title is-4"><strong>Isomorphic</strong></p>+ <p class="subtitle">Seamless web experience</p>+ </a>+ <a href="http://book.realworldhaskell.org/read/concurrent-and-multicore-programming.html" rel="noopener" class="column has-text-centered" target="_blank">+ <span class="icon is-large"><i class="fa fa-gears"></i></span>+ <p class="title is-4"><strong>Concurrent</strong></p>+ <p class="subtitle">Type-safe and polymorphic, GHC Haskell</p>+ </a>+ <a href="https://github.com/ghcjs/ghcjs/blob/master/doc/foreign-function-interface.md" rel="noopener" class="column has-text-centered" target="_blank">+ <span class="icon is-large"><i class="fa fa-code-fork"></i></span>+ <p class="title is-4"><strong>Interoperable</strong></p>+ <p class="subtitle">via the GHCJS FFI</p>+ </a>+ </nav>+ </div>+ </div>+ </section>+ <footer class="footer">+ <div class="container">+ <div class="content has-text-centered">+ <p><strong>Miso</strong> by <a style="color:#363636;" href="https://github.com/dmjio/miso">dmjio</a>. BSD3<a style="color:#363636;" href="https://opensource.org/licenses/BSD-3-Clause"> licensed.</a></p>+ <p>The source code for this website is located <a style="color:#363636;" href="https://github.com/dmjio/miso/tree/master/examples/haskell-miso.org"> here.</a></p>+ <p><a href="https://bulma.io"><img height="24" width="128" src="https://bulma.io/images/made-with-bulma.png" alt="Made with Bulma"></img></a></p>+ <p><a href="https://github.com/dmjio/miso"><span class="icon is-large"><i class="fa fa-github"></i></span></a></p>+ </div>+ </div>+ </footer>+ </div>+ </body>+</html>
+ miso-from-html.cabal view
@@ -0,0 +1,48 @@+name:+ miso-from-html+version:+ 0.1.0.0+synopsis:+ Convert HTML to miso View syntax+description:+ HTML parser that pretty prints to a Miso View+bug-reports:+ https://github.com/dmjio/miso-from-html/issues+license:+ BSD3+license-file:+ LICENSE+author:+ David Johnson+maintainer:+ djohnson.m@gmail.com+copyright:+ (c) David Johnson 2020+category:+ Web+build-type:+ Simple+extra-source-files:+ README.md+ index.html+cabal-version:+ >=1.10++executable miso-from-html+ main-is:+ Main.hs+ ghc-options:+ -Wall+ build-depends:+ attoparsec+ , base < 5+ , bytestring+ , containers+ , pretty-simple+ , text+ default-language:+ Haskell2010++source-repository head+ type: git+ location: https://github.com/dmjio/miso-from-html.git