miso-from-html 0.2.0.0 → 0.3.0.0
raw patch · 7 files changed
+598/−300 lines, 7 filesdep +fourmoludep +html-parsedep +misodep −attoparsecdep ~bytestringdep ~containersdep ~pretty-simplesetup-changednew-component:exe:app
Dependencies added: fourmolu, html-parse, miso, miso-from-html, mtl
Dependencies removed: attoparsec
Dependency ranges changed: bytestring, containers, pretty-simple, text
Files
- Main.hs +0/−273
- README.md +36/−13
- Setup.hs +0/−2
- app/Main.hs +192/−0
- exe/Main.hs +17/−0
- miso-from-html.cabal +56/−12
- src/Miso/From/Html.hs +297/−0
− Main.hs
@@ -1,273 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# 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))- | T.any (=='-') k =- mconcat- [ "textProp \""- , T.unpack k- , "\""- , " \""- , T.unpack v- , "\""- ]- | otherwise =- mconcat- [ T.unpack k- , "_ "- , "\""- , T.unpack v- , "\""- ]- show (Attr "checked" Nothing) =- "checked_ True"- 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 '/' <|> 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 find 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- [ "area"- , "base"- , "br"- , "col"- , "embed"- , "hr"- , "img"- , "input"- , "link"- , "meta"- , "param"- , "source"- , "track"- , "wbr"- ]--closeTag :: Parser ()-closeTag = do- _ <- string "</"- _ <- takeWhile1 isAlphaNum- _ <- char '>'- pure ()--main :: IO ()-main = do- file <- stripDoctype . 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)--stripDoctype :: Text -> Text-stripDoctype t = do- let firstLine = T.takeWhile (/='\n') t- if "<!doctype html>" `T.isPrefixOf` (T.toLower firstLine)- then T.drop 1 (T.dropWhile (/='\n') t)- else t---- | 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
@@ -1,18 +1,9 @@-miso-from-html+🍜 miso-from-html ===================---[](https://github.com/dmjio/miso-from-html/blob/master/miso-from-html/LICENSE)-[](https://travis-ci.org/dmjio/miso-from-html)+Use [live](https://miso-from-html.haskell-miso.org) from your browser. 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@@ -21,7 +12,7 @@ <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">+ <img src="https://bulma.io/images/bulma-logo.png" width="112" height="28" /> <a>ok<p>hey</p></a> </a> </div>@@ -60,8 +51,40 @@ ] ``` +### Limitations++Currently operates on a single top-level node, not on a list of nodes.++This is invalid since there is no single top-level parent node.++```html+<div>+ foo+</div>+<div>+ bar+</div>+```++This is valid++```html+<div>+ <div>+ foo+ </div>+ <div>+ bar+ </div>+</div>+```++Also, if your HTML isn't parsing, make sure it's valid.++When in doubt, check the [W3C validation service](https://validator.w3.org/#validate_by_input).+ ### Test ```bash-$ nix-shell --run 'runghc Main.hs < index.html'+nix develop --command bash -c cabal run < index.html' ```
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+module Main (main) where+-----------------------------------------------------------------------------+import Control.Monad+import Prelude hiding (unlines, rem)+-----------------------------------------------------------------------------+import Miso+import Miso.Html hiding (title_)+import Miso.Html.Property+import Miso.Navigator+import Miso.Lens hiding (set)+import Miso.From.Html (process)+import Miso.String+import qualified Miso.CSS as CSS+-----------------------------------------------------------------------------+import Ormolu (ormolu)+import Ormolu.Config+-----------------------------------------------------------------------------+#ifdef WASM+foreign export javascript "hs_start" main :: IO ()+#endif+-----------------------------------------------------------------------------+data Mode+ = Editing+ | Clear+ deriving (Show, Eq)+-----------------------------------------------------------------------------+data Model+ = Model+ { _value :: MisoString+ , _mode :: Mode+ } deriving (Show, Eq)+-----------------------------------------------------------------------------+instance ToMisoString Model where+ toMisoString (Model v _) = toMisoString v+-----------------------------------------------------------------------------+value :: Lens Model MisoString+value = lens _value $ \m v -> m { _value = v }+-----------------------------------------------------------------------------+mode :: Lens Model Mode+mode = lens _mode $ \m v -> m { _mode = v }+-----------------------------------------------------------------------------+data Action+ = OnInput MisoString+ | CopyToClipboard+ | Copied+ | ErrorCopy JSVal+ | SetText MisoString+ | ClearText+-----------------------------------------------------------------------------+main :: IO ()+main = startApp defaultEvents app+-----------------------------------------------------------------------------+formatString :: MisoString -> IO MisoString+formatString = fmap toMisoString . ormolu cfg "<input>" . fromMisoString+ where+ cfg =+ defaultConfig+ { cfgPrinterOpts =+ defaultPrinterOpts+ { poColumnLimit = pure (ColumnLimit 50)+ }+ }+-----------------------------------------------------------------------------+app :: App Model Action+app = (component (Model mempty Clear) updateModel viewModel)+#ifndef WASM+ { styles =+ [ Href "assets/style.css"+ , Href "https://cdn.jsdelivr.net/npm/toastify-js/src/toastify.min.css" + ]+ , scripts =+ [ Src "https://cdn.jsdelivr.net/npm/toastify-js"+ ]+ }+#endif+-----------------------------------------------------------------------------+updateModel :: Action -> Effect parent Model Action+updateModel (OnInput input) = do+ mode .= Editing+ let output = ms (process (fromMisoString input))+ io (SetText <$> liftIO (formatString output))+updateModel CopyToClipboard = do+ input <- use value+ copyClipboard input Copied ErrorCopy+updateModel (ErrorCopy err) =+ io_ (consoleLog' err)+updateModel Copied =+ io_ (showToast "Copied to clipboard...")+updateModel (SetText txt) =+ value .= txt+updateModel ClearText = do+ mode .= Clear+ value .= mempty+-----------------------------------------------------------------------------+githubStar :: View model action+githubStar = iframe_+ [ title_ "GitHub"+ , height_ "30"+ , width_ "170"+ , textProp "scrolling" "0"+ , textProp "frameborder" "0"+ , src_+ "https://ghbtns.com/github-btn.html?user=haskell-miso&repo=miso-from-html&type=star&count=true&size=large"+ ]+ []+-----------------------------------------------------------------------------+viewModel :: Model -> View Model Action+viewModel (Model input mode_) =+ div_+ []+ [ githubStar+ , div_+ [ CSS.style_ [ CSS.textAlign "center" ]+ ]+ [ h1_ []+ [ "🍜 miso-from-html"+ ]+ , h4_ []+ [ "Convert HTML to miso"+ ]+ , button_+ [ onClick ClearText+ , CSS.style_+ [ CSS.width "120px"+ , CSS.height "50px"+ , CSS.fontSize "20px"+ ]+ ]+ [ "Clear"+ ]+ , button_+ [ onClick CopyToClipboard+ , CSS.style_+ [ CSS.width "120px"+ , CSS.height "50px"+ , CSS.margin "5px"+ , CSS.fontSize "20px"+ ]+ ]+ [ "Copy"+ ]+ ]+ , div_+ [ className "container"+ ]+ [ div_+ [ class_ "panel"+ ]+ [ div_+ [ class_ "panel-header"+ ]+ [ "HTML Input"+ ]+ , optionalAttrs+ textarea_+ [ placeholder_ "Type your text here..."+ , class_ "input-area"+ , onInput OnInput+ ] (mode_ == Clear)+ [ value_ ""+ ]+ []+ ]+ , div_+ [ class_ "panel" ]+ [ div_+ [ class_ "panel-header" ]+ [ "miso View output"+ ]+ , pre_+ [ id_ "output"+ , class_ "output-area"+ ]+ [ text input+ ]+ ]+ ]+ ]+-----------------------------------------------------------------------------+showToast :: MisoString -> IO ()+showToast msg = do+ o <- create+ set @MisoString "text" msg o+ set @Int "duration" 3000 o+ toastify <- new (jsg "Toastify") [o]+ void $ toastify # ("showToast" :: MisoString) $ ()+-----------------------------------------------------------------------------
+ exe/Main.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+module Main (main) where+-----------------------------------------------------------------------------+import qualified Data.Text.IO as T+-----------------------------------------------------------------------------+import Miso.From.Html (processPretty)+-----------------------------------------------------------------------------+main :: IO ()+main = T.putStrLn =<< processPretty <$> T.getContents+-----------------------------------------------------------------------------
miso-from-html.cabal view
@@ -1,7 +1,8 @@+cabal-version: 3.0 name: miso-from-html version:- 0.2.0.0+ 0.3.0.0 synopsis: Convert HTML to miso View syntax description:@@ -9,15 +10,15 @@ bug-reports: https://github.com/dmjio/miso-from-html/issues license:- BSD3+ BSD-3-Clause license-file: LICENSE author: David Johnson maintainer:- djohnson.m@gmail.com+ code@dmj.io copyright:- (c) David Johnson 2020+ (c) David Johnson 2025 category: Web build-type:@@ -25,21 +26,64 @@ extra-source-files: README.md index.html-cabal-version:- >=1.10 +common wasm+ if arch(wasm32)+ ghc-options:+ -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start"+ cpp-options:+ -DWASM++library+ default-language:+ Haskell2010+ ghc-options:+ -Wall+ hs-source-dirs:+ src+ exposed-modules:+ Miso.From.Html+ build-depends:+ base < 5,+ bytestring < 0.13,+ containers < 0.9,+ html-parse < 0.3,+ miso < 1.10,+ mtl < 2.4,+ pretty-simple < 4.2,+ text < 2.2++-- build w/ vanilla ghc executable miso-from-html main-is: Main.hs+ hs-source-dirs:+ exe ghc-options: -Wall build-depends:- attoparsec- , base < 5- , bytestring- , containers- , pretty-simple- , text+ base < 5,+ miso-from-html,+ text+ default-language:+ Haskell2010++-- Build w/ WASM / JS backends (or vanilla for hot-reload w/ jssaddle)+executable app+ import:+ wasm+ main-is:+ Main.hs+ ghc-options:+ -Wall+ hs-source-dirs:+ app+ build-depends:+ base < 5,+ miso,+ miso-from-html,+ fourmolu < 0.20+ default-language: Haskell2010
+ src/Miso/From/Html.hs view
@@ -0,0 +1,297 @@+-----------------------------------------------------------------------------+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+module Miso.From.Html where+-----------------------------------------------------------------------------+import Data.Char+import Control.Monad (guard)+import Control.Monad.State+import Control.Applicative+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.Lazy as LT+import qualified Data.Text as T+import Prelude hiding (takeWhile)+import Text.HTML.Parser+import Text.Pretty.Simple+import Text.HTML.Tree+-----------------------------------------------------------------------------+type IsOpen = Bool+-----------------------------------------------------------------------------+data HTML+ = Node IsOpen HTMLTagName [ HTMLAttr ] [ HTML ]+ | TextNode Text+ deriving stock (Eq)+-----------------------------------------------------------------------------+newtype CSS = CSS (Map Text Text)+ deriving stock (Eq)+ deriving newtype (Monoid, Semigroup)+-----------------------------------------------------------------------------+instance Show CSS where+ show (CSS hmap) =+ mconcat+ [ "CSS.style [ "+ , intercalate "," (go <$> M.assocs hmap)+ , " ]"+ ]+ where+ go (k,v) = "\"" <>+ T.unpack (T.strip k) <> "\" =: " <> "\"" <>+ T.unpack (T.strip v) <> "\""+-----------------------------------------------------------------------------+data HTMLAttr = HTMLAttr Text (Maybe Text)+ deriving (Eq)+-----------------------------------------------------------------------------+instance Show HTML where+ show (TextNode x) = "\"" <> T.unpack x <> "\""+ show (Node isOpen t as cs) =+ mconcat $+ [ T.unpack t+ , "_ "+ , show as+ ] +++ [ show cs+ | isOpen+ ]+-----------------------------------------------------------------------------+upper :: Text -> Text+upper (T.uncons -> Just (h,xs)) = T.cons (toUpper h) xs+upper x = x+-----------------------------------------------------------------------------+instance Show HTMLAttr where+ show (HTMLAttr "style" (Just v)) =+ mconcat+ [ T.unpack v+ ]+ show (HTMLAttr k (Just v))+ | "stroke-" `T.isPrefixOf` k+ , Just rest <- T.stripPrefix "stroke-" k =+ mconcat+ [ " stroke" <> T.unpack (upper rest) <> "_"+ , " \""+ , T.unpack v+ , "\" "+ ]+ | "data-" `T.isPrefixOf` k+ , Just rest <- T.stripPrefix "data-" k =+ mconcat+ [ " data_ \""+ , T.unpack rest+ , "\""+ , " \""+ , T.unpack v+ , "\" "+ ]+ | "aria-" `T.isPrefixOf` k+ , Just rest <- T.stripPrefix "aria-" k =+ mconcat+ [ " aria_ \""+ , T.unpack rest+ , "\""+ , " \""+ , T.unpack v+ , "\" "+ ]+ | T.any (=='-') k =+ mconcat+ [ " textProp \""+ , T.unpack k+ , "\""+ , " \""+ , T.unpack v+ , "\" "+ ]+ | otherwise =+ mconcat+ [ " "+ , T.unpack k+ , "_ "+ , "\""+ , T.unpack v+ , "\" "+ ]+ show (HTMLAttr x@(T.isPrefixOf "data-" -> True) Nothing) =+ case T.stripPrefix "data-" x of+ Just rest -> "data_ " <> "\"" <> T.unpack rest <> "\"" <> " \"\""+ Nothing -> T.unpack x+ show (HTMLAttr "checked" Nothing) =+ "checked_ True"+ show (HTMLAttr k Nothing) =+ mconcat+ [ "textProp \""+ , T.unpack k+ , "\" \"\""+ ]+-----------------------------------------------------------------------------+type HTMLTagName = Text+-----------------------------------------------------------------------------+html :: Parser HTML+html = withoutKids <|> withKids+ where+ withoutKids =+ textNode <|> tagSelfClose+ withKids = do+ (openName, attrs) <- tagOpen+ kids <- many html+ closeName <- tagClose+ guard (openName == closeName)+ pure (Node True openName attrs kids)+-----------------------------------------------------------------------------+tagOpen :: Parser (TagName, [HTMLAttr])+tagOpen = do+ TagOpen openName attrs <-+ satisfy $ \case+ TagOpen{} -> True+ _ -> False+ let htmlAttrs =+ [ processStyle (HTMLAttr attrName value)+ | Attr attrName attrValue <- attrs+ , let value+ | T.null attrValue = Nothing+ | otherwise = Just attrValue+ ]+ pure (openName, htmlAttrs)+-----------------------------------------------------------------------------+tagClose :: Parser TagName+tagClose = do+ TagClose closeName <-+ satisfy $ \case+ TagClose{} -> True+ _ -> False+ pure closeName+-----------------------------------------------------------------------------+tagSelfClose :: Parser HTML+tagSelfClose = do+ TagSelfClose name attrs <-+ satisfy $ \case+ TagSelfClose {} -> True+ _ -> False+ let htmlAttrs =+ [ processStyle (HTMLAttr attrName value)+ | Attr attrName attrValue <- attrs+ , let value+ | T.null attrValue = Nothing+ | otherwise = Just attrValue+ ]+ pure (Node False name htmlAttrs [])+-----------------------------------------------------------------------------+textNode :: Parser HTML+textNode = leaf <|> leafChar+ where+ leaf :: Parser HTML+ leaf = do+ ContentText txt <-+ satisfy $ \case+ ContentText {} -> True+ _ -> False+ pure (TextNode txt)++ leafChar :: Parser HTML+ leafChar = do+ ContentChar t <-+ satisfy $ \case+ ContentChar {} -> True+ _ -> False+ pure (TextNode (T.singleton t))+------------------------------------------------------------------------------+processStyle :: HTMLAttr -> HTMLAttr+processStyle (HTMLAttr "style" (Just cssText)) =+ HTMLAttr "style" $ Just (T.pack (show parsedCss))+ where+ parsedCss :: CSS+ parsedCss = CSS cssMap+ where+ cssMap+ = M.fromList+ [ (k,v)+ | [k,v] <- T.splitOn ":" <$> T.splitOn ";" cssText+ ]+processStyle attr = attr+------------------------------------------------------------------------------+isComment :: Token -> Bool+isComment Comment {} = True+isComment _ = False+-----------------------------------------------------------------------------+isDoctype :: Token -> Bool+isDoctype Doctype {} = True+isDoctype _ = False+-----------------------------------------------------------------------------+isEmptyTextNode :: Token -> Bool+isEmptyTextNode (ContentText txt)+ = T.null+ $ T.filter (`notElem` ['\n', '\t', ' '])+ $ txt+isEmptyTextNode _ = False+-----------------------------------------------------------------------------+getTokens :: Text -> [Token]+getTokens input = preprocess $+ let+ tokens = parseTokens input+ in+ [ case t of+ ContentText txt ->+ ContentText (T.strip txt)+ _ -> t+ | t <- tokens+ , not (isComment t)+ && not (isDoctype t)+ && not (isEmptyTextNode t)+ ]+-----------------------------------------------------------------------------+process :: Text -> Text+process input =+ case parse html (getTokens input) of+ Right r ->+ T.pack (show r)+ Left e ->+ T.pack (show e)+-----------------------------------------------------------------------------+preprocess :: [Token] -> [Token]+preprocess = fmap go+ where+ go (TagOpen name attrs)+ | name `elem` nonClosing = TagSelfClose name attrs+ | otherwise = TagOpen name attrs+ go x = x+-----------------------------------------------------------------------------+processPretty :: Text -> Text+processPretty input =+ case parse html (getTokens input) of+ Right r ->+ LT.toStrict (pShow r)+ Left e ->+ LT.toStrict (pShow e)+-----------------------------------------------------------------------------+data ParseError a+ = UnexpectedParse [Token]+ | Ambiguous [(a, [Token])]+ | NoParses Token+ | EmptyStream+ deriving (Show, Eq)+-----------------------------------------------------------------------------+parse :: Parser a -> [Token] -> Either (ParseError a) a+parse _ [] = Left EmptyStream+parse parser tokens =+ case runStateT parser tokens of+ [] -> Left (NoParses (last tokens))+ [(x, [])] -> Right x+ [(_, xs)] -> Left (UnexpectedParse xs)+ xs -> Left (Ambiguous xs)+-----------------------------------------------------------------------------+type Parser a = StateT [Token] [] a+-----------------------------------------------------------------------------+satisfy :: (Token -> Bool) -> Parser Token+satisfy f = StateT $ \tokens ->+ case tokens of+ t : ts | f t -> [(t, ts)]+ _ -> []+-----------------------------------------------------------------------------