lasercutter (empty) → 0.1.0.0
raw patch · 12 files changed
+1310/−0 lines, 12 filesdep +QuickCheckdep +basedep +checkerssetup-changed
Dependencies added: QuickCheck, base, checkers, containers, criterion, deepseq, lasercutter, profunctors, scalpel, selective, tagsoup, text, witherable
Files
- CHANGELOG.md +17/−0
- LICENSE +30/−0
- README.md +33/−0
- Setup.hs +2/−0
- bench/HTML.hs +128/−0
- bench/Main.hs +112/−0
- bench/ScalpelSkipScript.hs +58/−0
- lasercutter.cabal +149/−0
- src/Lasercutter.hs +222/−0
- src/Lasercutter/Internal.hs +132/−0
- src/Lasercutter/Types.hs +159/−0
- test/Spec.hs +268/−0
+ CHANGELOG.md view
@@ -0,0 +1,17 @@+# Changelog for `lasercutter`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).+++## 0.1.0.0 - 2022-09-07++- Hello world!+++## Unreleased++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Sandy Maguire nor the names of other+ 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+OWNER 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.
+ README.md view
@@ -0,0 +1,33 @@+# lasercutter++## Dedication++> The scalpel won't make you happy.+>+> --Demi Moore+++## Overview++`lasercutter` is a high-powered, high-speed, and high-tech tree parser for+Haskell. It's somewhere between 500x and 1000x faster than `scalpel` on+benchmarks and real workloads.++<p align="center">+<img src="https://raw.githubusercontent.com/isovector/lasercutter/master/bench.png" alt="Benchmark results" title="Benchmark results">+</p>++Not only is it smokin' fast, `lasercutter` is a general tool for chopping up any+sort of tree you've got --- not just HTML!++Best of all, `lasercutter` rips through trees in a single pass. This is truly+space-age stuff!+++## Acknowledgments++The core abstraction here is the brainchild of [Xia Li-yao][lyxia] --- huge+shout-outs to him for turning my vague ideas into reality.++[lyxia]: https://github.com/Lysxia+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/HTML.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module HTML where++import Control.Monad (join)+import Data.Bool (bool)+import Data.Foldable (traverse_)+import Data.Set (Set)+import Data.Text (Text)+import Lasercutter+import Text.HTML.TagSoup (Tag(TagText, TagOpen))+import Text.HTML.TagSoup.Tree+++type HTML = TagTree Text++data Selector+ = Both Selector Selector+ | Alt Selector Selector+ | Negate Selector+ | HasTag Text+ | WithAttr Text (Maybe Text -> Bool)++matchSelector :: Selector -> TagTree Text -> Bool+matchSelector (Both se1 se2) tt = matchSelector se1 tt && matchSelector se2 tt+matchSelector (Alt se1 se2) tt = matchSelector se1 tt || matchSelector se2 tt+matchSelector (Negate se) tt = not $ matchSelector se tt+matchSelector (HasTag txt) (TagBranch txt' _ _) = txt == txt'+matchSelector (HasTag txt) (TagLeaf (TagOpen txt' _)) = txt == txt'+matchSelector (HasTag _) (TagLeaf _) = False+matchSelector (WithAttr txt f) (TagBranch _ x0 _) = f $ lookup txt x0+matchSelector (WithAttr txt f) (TagLeaf (TagOpen _ attrs)) = f $ lookup txt attrs+matchSelector (WithAttr _ _) (TagLeaf _) = False++instance IsTree (TagTree t) where+ getChildren (TagBranch _ _ tts) = tts+ getChildren (TagLeaf _) = []++at :: Text -> Parser bc (TagTree Text) a -> Parser bc (TagTree Text) a+at t p+ = expect+ $ bool+ <$> pure Nothing+ <*> fmap Just p+ <*> proj (matchSelector $ HasTag t)++textOf :: TagTree a -> Maybe a+textOf = \case+ TagLeaf (TagText txt) -> Just txt+ _ -> Nothing++text :: Parser bc (TagTree a) (Maybe a)+text = proj textOf++getText :: Parser bc (TagTree Text) Text+getText = expect text++example :: TagTree Text+example =+ TagBranch "html" [("lang", "en")]+ [ TagBranch "head" []+ [ TagBranch "title" [] [ TagLeaf $ TagText "Hello World!" ]+ , TagBranch "style" [("type", "text/css")]+ [ TagLeaf $ TagText "css"+ ]+ ]+ , TagBranch "body" []+ [ TagBranch "h1" [] [ TagLeaf $ TagText "Hi" ]+ , TagBranch "p" [("id", "lorem")] [ TagLeaf $ TagText "lorem ipsum" ]+ , TagBranch "p" []+ [ TagLeaf $ TagText "more p"+ , TagBranch "b" []+ [ TagLeaf $ TagText "bold"+ ]+ , TagLeaf $ TagText "done"+ ]+ , TagBranch "script" []+ [ TagLeaf $ TagText "dont want no scripts"+ ]+ ]+ ]++chroot :: Selector -> Parser bc HTML a -> Parser bc HTML a+chroot s = one . chroots s+++chroots :: Selector -> Parser bc HTML a -> Parser bc HTML [a]+chroots = target . matchSelector+++texts :: Parser bc HTML [Text]+texts = targetMap textOf+++texts' :: Selector -> Parser bc HTML [Text]+texts' sel =+ fmap (catMaybes . join) $ target (matchSelector sel) $ onChildren text++isText :: HTML -> Bool+isText (TagLeaf (TagText _)) = True+isText _ = False+++textNoScript :: Parser (Set Text) HTML [Text]+textNoScript =+ asum+ [ at "h1" texts+ , at "p" texts+ , at "b" texts+ ]+++getTag :: HTML -> [Text]+getTag (TagBranch txt _ _) = pure txt+getTag (TagLeaf (TagOpen txt _)) = pure txt+getTag _ = mempty+++main :: IO ()+main = traverse_ (traverse_ print) $ runParser getTag example+ $ fmap catMaybes+ $ target isText+ $ bool+ <$> text+ <*> pure Nothing+ <*> fmap ((`elem` ["script", "style"]) . head) breadcrumbs+
+ bench/Main.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE NoMonoLocalBinds #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Control.Applicative (liftA3)+import Control.DeepSeq+import Control.Exception (evaluate)+import Criterion.Main+import Data.Bool (bool)+import Data.Foldable (find)+import Data.Maybe (fromJust, catMaybes)+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import GHC.Generics (Generic)+import qualified HTML as Laser+import qualified Lasercutter as Laser+import qualified ScalpelSkipScript as Scalpel+import qualified Text.HTML.Scalpel as Scalpel+import Text.HTML.TagSoup (parseTags, Tag(..))+import Text.HTML.TagSoup.Tree (tagTree, TagTree(..))++deriving stock instance Generic (TagTree Text)+deriving stock instance Generic (Tag Text)+deriving anyclass instance NFData (TagTree Text)+deriving anyclass instance NFData (Tag Text)+++scalpelTitle :: Scalpel.Scraper Text Text+scalpelTitle = Scalpel.chroot "title" $ Scalpel.text "title"++laserTitle :: Laser.Parser bc Laser.HTML Text+laserTitle = Laser.chroot (Laser.HasTag "title") $ Laser.one $ Laser.texts++-- TODO(sandy): there is a faster version here using `texts` directly+scalpelContent :: Scalpel.Scraper Text [Text]+scalpelContent =+ let sel = "div" Scalpel.@: [ "class" Scalpel.@= "blog-content row" ]+ in Scalpel.chroot sel $ Scalpel.texts sel+++scalpelBodyText :: Scalpel.Scraper Text [Text]+scalpelBodyText = Scalpel.textsWithoutScripts "body"++laserContent :: Laser.Parser bc Laser.HTML [Text]+laserContent = Laser.chroot (Laser.Both (Laser.HasTag "div") (Laser.WithAttr "class" (== Just "blog-content row"))) $ Laser.texts++laserBodyText :: Laser.Parser (Set Text) Laser.HTML [Text]+laserBodyText = fmap (filter (not . T.null) . fmap T.strip) $ Laser.chroot (Laser.HasTag "body") $ fmap catMaybes $ Laser.target Laser.isText $+ bool+ <$> Laser.text+ <*> pure Nothing+ <*> fmap (\bc -> any (flip S.member bc)+ [ "style"+ , "script"+ , "noscript"+ , "li"+ , "ul"+ , "ol"+ , "iframe"+ , "nav"+ , "object"+ , "source"+ , "svg"+ , "template"+ , "track"+ , "select"+ , "option"+ , "button"+ , "canvas"+ , "nav"+ , "h1"+ , "h2"+ , "h3"+ , "h4"+ , "h5"+ , "h6"+ , "sup"+ , "sub"+ ]) Laser.breadcrumbs+++main :: IO ()+main = do+ !input_tags <- force . parseTags <$> T.readFile "bench/data/yes2.html"+ !input_tree <- evaluate $ force $ fromJust $ find (Laser.matchSelector $ Laser.HasTag "html") $ tagTree input_tags++ -- proof that we get equivalent results for bodytext+ print $ fmap (T.intercalate " ") (Scalpel.scrape scalpelBodyText input_tags)+ == fmap (T.intercalate " ") (Laser.runParser (S.fromList . Laser.getTag) input_tree laserBodyText)++ let+ benchScalpel p = bench "scalpel" $ whnf ( Scalpel.scrape p) input_tags+ benchLaser p = bench "lasercutter" $ whnf (flip (Laser.runParser $ S.fromList . Laser.getTag) p) input_tree+ benchThem name ps pl =+ bgroup name+ [ benchScalpel ps+ , benchLaser pl+ ]++ defaultMain+ [ benchThem "title" scalpelTitle laserTitle+ , benchThem "content" scalpelContent laserContent+ , benchThem "body text" scalpelBodyText laserBodyText+ , benchThem "everything"+ (liftA3 (,,) scalpelTitle scalpelContent scalpelBodyText)+ (liftA3 (,,) laserTitle laserContent laserBodyText)+ ]+
+ bench/ScalpelSkipScript.hs view
@@ -0,0 +1,58 @@+module ScalpelSkipScript (textsWithoutScripts) where++import Control.Applicative+import Data.Foldable+import Data.Text (Text)+import qualified Data.Text as T+import Text.HTML.Scalpel++textsWithoutScripts :: Selector -> Scraper Text [Text]+textsWithoutScripts sel = chroot sel $ textWithoutScripts++textWithoutScripts :: Scraper Text [Text]+textWithoutScripts = fmap (filter (not . T.null) . fmap T.strip) $ inSerial $ many $ stepNext innerScraper+ where+ innerScraper :: Scraper Text Text+ innerScraper = plainText+ <|> skip+ <|> fmap (T.intercalate " " . filter (not . T.null)) unknown++ plainText :: Scraper Text Text+ plainText = fmap T.strip $ text (textSelector `atDepth` 0)++ skipMe :: Selector -> Scraper Text Text+ skipMe what = "" <$ recurseOn what++ skip :: Scraper Text Text+ skip = asum+ [ skipMe "style"+ , skipMe "script"+ , skipMe "noscript"+ , skipMe "li"+ , skipMe "ul"+ , skipMe "ol"+ , skipMe "iframe"+ , skipMe "nav"+ , skipMe "object"+ , skipMe "source"+ , skipMe "svg"+ , skipMe "template"+ , skipMe "track"+ , skipMe "select"+ , skipMe "option"+ , skipMe "button"+ , skipMe "canvas"+ , skipMe "nav"+ , skipMe "h1"+ , skipMe "h2"+ , skipMe "h3"+ , skipMe "h4"+ , skipMe "h5"+ , skipMe "h6"+ , skipMe "sup"+ , skipMe "sub"+ ]++ unknown = recurseOn anySelector++ recurseOn tag = chroot (tag `atDepth` 0) $ textWithoutScripts
+ lasercutter.cabal view
@@ -0,0 +1,149 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: lasercutter+version: 0.1.0.0+synopsis: A high-powered, single-pass tree parser.+description: Please see the README on GitHub at <https://github.com/isovector/lasercutter#readme>+category: Parsing+homepage: https://github.com/isovector/lasercutter#readme+bug-reports: https://github.com/isovector/lasercutter/issues+author: Sandy Maguire+maintainer: sandy@sandymaguire.me+copyright: Sandy Maguire+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/isovector/lasercutter++library+ exposed-modules:+ Lasercutter+ Lasercutter.Internal+ Lasercutter.Types+ other-modules:+ Paths_lasercutter+ hs-source-dirs:+ src+ default-extensions:+ BangPatterns+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ GADTs+ ImplicitPrelude+ LambdaCase+ MonomorphismRestriction+ OverloadedStrings+ ScopedTypeVariables+ StandaloneDeriving+ StrictData+ TupleSections+ TypeApplications+ TypeFamilies+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , profunctors+ , selective+ , witherable+ default-language: Haskell2010++test-suite lasercutter-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_lasercutter+ hs-source-dirs:+ test+ default-extensions:+ BangPatterns+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ GADTs+ ImplicitPrelude+ LambdaCase+ MonomorphismRestriction+ OverloadedStrings+ ScopedTypeVariables+ StandaloneDeriving+ StrictData+ TupleSections+ TypeApplications+ TypeFamilies+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , checkers+ , containers+ , lasercutter+ , profunctors+ , selective+ , witherable+ default-language: Haskell2010++benchmark lasercutter-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ HTML+ ScalpelSkipScript+ Paths_lasercutter+ hs-source-dirs:+ bench+ default-extensions:+ BangPatterns+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ GADTs+ ImplicitPrelude+ LambdaCase+ MonomorphismRestriction+ OverloadedStrings+ ScopedTypeVariables+ StandaloneDeriving+ StrictData+ TupleSections+ TypeApplications+ TypeFamilies+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -O2+ build-depends:+ base >=4.7 && <5+ , containers+ , criterion+ , deepseq+ , lasercutter+ , profunctors+ , scalpel+ , selective+ , tagsoup+ , text+ , witherable+ default-language: Haskell2010
+ src/Lasercutter.hs view
@@ -0,0 +1,222 @@+module Lasercutter+ ( -- * Core types+ Parser+ , runParser+ , IsTree (..)++ -- * Building parsers+ -- ** Primitives+ , self+ , proj++ -- ** Controlling failure+ , expect+ , one+ , try+ , empty+ , (<|>)++ -- ** Traversing trees+ , onChildren+ , onSingleChild+ , target+ , targetMap++ -- ** Conditional parsing+ , when+ , whenNode+ , ifS+ , ifNode++ -- ** Breadcrumbs+ -- | All parsers support a notion of *breadcrumbs* --- a monoid that gets+ -- accumulated along subtrees. Callers to 'runParser' can choose+ -- a *summarization* function which describes how to generate the breadcrumb+ -- monoid from the current node.+ --+ -- Breadcrumbs are often used to refine the results of 'target', which has no+ -- notion of history, and thus can be too coarse for many position-depending+ -- parsing tasks.+ , breadcrumbs+ , onBreadcrumbs+ , mapBreadcrumbs++ -- * Re-exports+ -- | The 'Parser' is an instance of all of the following classes, and thus+ -- all of these methods are available on 'Parser's.++ -- ** 'Profunctor'+ -- | Even though 'Parser's are contravariant in their breadcrumbs and+ -- tree type, this instance targets only the tree. Use 'mapBreadcrumbs' to+ -- modify the breadcrumbs.+ , dimap+ , rmap+ , lmap++ -- ** 'Applicative'+ , liftA2++ -- ** 'Alternative'+ , optional+ , guard+ , asum++ -- ** 'Filterable'+ , mapMaybe+ , catMaybes++ -- ** 'Selective'+ -- | 'Parser's are boring 'Selective' functors that are unfortunately unable+ -- to elide any effects. Nevertheless, the 'Selective' API is often quite+ -- useful for everyday parsing tasks.+ , select+ , (<*?)+ , branch+ , fromMaybeS+ , orElse+ , andAlso+ , (<||>)+ , (<&&>)+ , foldS+ , anyS+ , allS+ , bindS+ ) where++import Control.Applicative+import Control.Monad (guard)+import Control.Selective+import Data.Foldable (asum)+import Data.Maybe (listToMaybe, isJust)+import Lasercutter.Internal+import Lasercutter.Types+import Prelude hiding (filter)+import Witherable (Filterable (..))+import Data.Profunctor+++------------------------------------------------------------------------------+-- | Project a value out of the current node. This is the main way to build+-- primitive parsers.+--+-- * @'proj' f = 'fmap' f 'self'@+--+-- @since 0.1.0.0+proj :: (t -> a) -> Parser bc t a+proj f = fmap f self+++------------------------------------------------------------------------------+-- | Run the given parser on every immediate child of the current node.+--+-- @since 0.1.0.0+onChildren :: Parser bc t a -> Parser bc t [a]+onChildren = OnChildren+++------------------------------------------------------------------------------+-- | Run the given parser on every predicate-satisfying subtree of the current+-- node. This combinator is not recursive --- that is, if the predicate+-- is satisfied by both a node and its descendent, the descendent *will not*+-- receive the parser.+--+-- @since 0.1.0.0+target :: (t -> Bool) -> Parser bc t a -> Parser bc t [a]+target = Target+++------------------------------------------------------------------------------+-- | Get the breadcrumbs at the current node. This is useful for refining the+-- coarse-grained matches of 'target' by restricting matches to certain+-- subtrees.+--+-- @since 0.1.0.0+breadcrumbs :: Parser bc t bc+breadcrumbs = GetCrumbs+++------------------------------------------------------------------------------+-- | Get a value computed on the current breadcrumbs.+--+-- * @'onBreadcrumbs' f = 'fmap' f 'breadcrumbs'@+--+-- @since 0.1.0.0+onBreadcrumbs :: (bc -> a) -> Parser bc t a+onBreadcrumbs f = fmap f breadcrumbs+++------------------------------------------------------------------------------+-- | Run a parser on the immediate children of the current node, returning the+-- first success.+--+-- * @'onSingleChild' = 'fmap' 'listToMaybe' . 'onChildren'@+--+-- @since 0.1.0.0+onSingleChild :: Parser bc t a -> Parser bc t (Maybe a)+onSingleChild = fmap listToMaybe . onChildren+++------------------------------------------------------------------------------+-- | Get the current node.+--+-- @since 0.1.0.0+self :: Parser bc t t+self = Current+++------------------------------------------------------------------------------+-- | Get the first result of a list of results, failing if there are none.+--+-- * @'one' = 'expect' . 'fmap' 'listToMaybe'@+--+-- @since 0.1.0.0+one :: Parser bc t [a] -> Parser bc t a+one = expect . fmap listToMaybe+++------------------------------------------------------------------------------+-- | @'when' pc pa@ returns @pa@ when @pc@ evaluates to 'True', failing+-- otherwise.+--+-- @since 0.1.0.0+when+ :: Parser bc t Bool+ -> Parser bc t a+ -> Parser bc t a+when b tr = expect $ ifS b (fmap Just tr) $ pure Nothing+++------------------------------------------------------------------------------+-- | @'ifNode' f pt pf@ runs @pt@ when @f@ evaluates to 'True' on the+-- current node, running @pf@ otherwise.+--+-- * @'ifNode' f tr fl = 'ifS' ('proj' f) tr fl@+--+-- @since 0.1.0.0+ifNode+ :: (t -> Bool)+ -> Parser bc t a+ -> Parser bc t a+ -> Parser bc t a+ifNode f tr fl = ifS (proj f) tr fl+++------------------------------------------------------------------------------+-- | @'whenNode' f pa@ returns @pa@ when @pc@ evaluates to 'True' on the+-- current node, failing otherwise.+--+-- * @'whenNode' = 'when' . 'proj'@+--+-- @since 0.1.0.0+whenNode :: (t -> Bool) -> Parser bc t a -> Parser bc t a+whenNode = when . proj+++------------------------------------------------------------------------------+-- | Run the given function on every subtree, accumulating those which return+-- 'Just'.+--+-- @since 0.1.0.0+targetMap :: (t -> Maybe a) -> Parser bc t [a]+targetMap f = fmap catMaybes $ target (isJust . f) $ proj f+
+ src/Lasercutter/Internal.hs view
@@ -0,0 +1,132 @@+module Lasercutter.Internal where++import Control.Applicative+import Control.Monad (join)+import Data.Maybe (mapMaybe)+import Lasercutter.Types+++------------------------------------------------------------------------------+-- | Split a parser into a parser to run on the node's children, and how to+-- reassemble those pieces into a parser for the current node.+--+-- @since 0.1.0.0+split :: bc -> Parser bc t a -> t -> Split bc t a+split _ (Pure a) _ = ignoreChildren $ pure a+split cr GetCrumbs _ = ignoreChildren $ pure cr+split cr (LiftA2 f l r) tt =+ case (split cr l tt, split cr r tt) of+ (Split l' kl, Split r' kr) ->+ Split (LiftA2 (,) l' r') $ \(unzip -> (lcs, rcs)) ->+ LiftA2 f (kl lcs) (kr rcs)+split cr p0@(Target se pa) tt+ | se tt+ = continue (fmap pure) $ split cr pa tt+ | otherwise+ = Split p0 $ pure . join+split cr (Expect pa) tt = continue expect $ split cr pa tt+split _ (OnChildren pa) _ = Split pa pure+split _ Current tt = ignoreChildren $ pure tt+split _ Fail _ = Split Fail $ const $ Fail+++------------------------------------------------------------------------------+-- | There is no work to do for the children, so ignore them.+--+-- @since 0.1.0.0+ignoreChildren :: Parser bc t b -> Split bc t b+ignoreChildren = Split (pure ()) . const+++------------------------------------------------------------------------------+-- | Append a continuation after a 'Split'.+--+-- @since 0.1.0.0+continue :: (Parser bc t a -> Parser bc t b) -> Split bc t a -> Split bc t b+continue f (Split p k) = Split p $ f . k+++------------------------------------------------------------------------------+-- | Parse the current node by splitting the parser, accumulating the results+-- of each child, and then running the continuation.+--+-- @since 0.1.0.0+parseNode+ :: (Semigroup bc, IsTree t)+ => (t -> bc)+ -> bc+ -> Parser bc t a+ -> t+ -> Parser bc t a+parseNode summarize cr p tt =+ case split cr' p tt of+ Split (Pure a) k -> k [a]+ Split pa k -> k $ parseChildren summarize cr' pa $ getChildren tt+ where+ cr' = summarize tt <> cr+++------------------------------------------------------------------------------+-- | Run a parser on each child, accumulating the results.+--+-- @since 0.1.0.0+parseChildren+ :: (IsTree t, Semigroup bc)+ => (t -> bc)+ -> bc+ -> Parser bc t a+ -> [t]+ -> [a]+parseChildren summarize cr pa =+ mapMaybe $ getResult . parseNode summarize cr pa+++------------------------------------------------------------------------------+-- | Extract a value from a parser. The way the applicative evaluates,+-- all "combinator" effects are guaranteed to have been run by the time this+-- function gets called.+--+-- @since 0.1.0.0+getResult :: Parser bc t a -> Maybe a+getResult (Pure a) = pure a+getResult (LiftA2 f a b) = liftA2 f (getResult a) (getResult b)+getResult (Expect pa) = join $ getResult pa+getResult Fail = Nothing+getResult GetCrumbs = error "getResult: impossible"+getResult (Target _ _) = error "getResult: impossible"+getResult (OnChildren _) = error "getResult: impossible"+getResult Current = error "getResult: impossible"+++------------------------------------------------------------------------------+-- | Run a parser over a tree in a single pass.+--+-- @since 0.1.0.0+runParser+ :: (Monoid bc, IsTree t)+ => (t -> bc)+ -- ^ A means of summarizing the current node for tracking breadcrumbs.+ -- If you don't need breadcrumbs, use @'const' ()@.+ -> t+ -- ^ The tree to parse.+ -> Parser bc t a+ -- ^ How to parse the tree.+ -> Maybe a+runParser summarize tt =+ getResult . flip (parseNode summarize mempty) tt+++------------------------------------------------------------------------------+-- | Transformer the breadcrumbs of a 'Parser'.+--+-- @since 0.1.0.0+mapBreadcrumbs :: (bc' -> bc) -> Parser bc t a -> Parser bc' t a+mapBreadcrumbs _ (Pure a) = Pure a+mapBreadcrumbs t (LiftA2 f pa pb) = LiftA2 f (mapBreadcrumbs t pa) (mapBreadcrumbs t pb)+mapBreadcrumbs t GetCrumbs = fmap t GetCrumbs+mapBreadcrumbs t (Target p pa) = Target p $ mapBreadcrumbs t pa+mapBreadcrumbs t (OnChildren pa) = OnChildren $ mapBreadcrumbs t pa+mapBreadcrumbs _ Current = Current+mapBreadcrumbs t (Expect pa) = Expect $ mapBreadcrumbs t pa+mapBreadcrumbs _ Fail = Fail+
+ src/Lasercutter/Types.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE StrictData #-}++module Lasercutter.Types where++import Control.Applicative+import Control.Selective+import Data.Monoid+import Data.Profunctor+import Witherable+++------------------------------------------------------------------------------+-- | Lasercutter supports any inductive tree types, as witnessed by+-- 'getChildren'.+--+-- @since 0.1.0.0+class IsTree t where+ -- | Get all children of the current node.+ --+ -- @since 0.1.0.0+ getChildren :: t -> [t]+++------------------------------------------------------------------------------+-- | A tree parser which runs all queries in a single pass. This is+-- accomplished via a free encoding of the applicative structure, which can be+-- arbitrarily reassociated for better performance.+--+-- @since 0.1.0.0+data Parser bc t a where+ -- | The free 'pure' constructor.+ --+ -- @since 0.1.0.0+ Pure :: a -> Parser bc t a+ -- | The free 'liftA2' constructor. This is an inlining of Day convolution.+ --+ -- @since 0.1.0.0+ LiftA2 :: (b -> c -> a) -> Parser bc t b -> Parser bc t c -> Parser bc t a+ -- | Get the breadcrumbs at the current part of the tree.+ --+ -- @since 0.1.0.0+ GetCrumbs :: Parser bc t bc+ -- | Run the given parser at every subtree which matches the given predicate.+ -- This is not recursive --- that is, a given subtree only runs the given+ -- parser once, not in all further matching subtrees.+ --+ -- @since 0.1.0.0+ Target :: (t -> Bool) -> Parser bc t a -> Parser bc t [a]+ -- | Run the given parser on each child of the current node.+ --+ -- @since 0.1.0.0+ OnChildren :: Parser bc t a -> Parser bc t [a]+ -- | Get the current node.+ --+ -- @since 0.1.0.0+ Current :: Parser bc t t+ -- | Swallow a parsed 'Maybe', failing the parser if it was 'Nothing'. Don't+ -- use this constructor explicitly; prefer 'expect' which maintains some+ -- invariants.+ --+ -- 'optional' is the inverse to this parser.+ --+ -- @since 0.1.0.0+ Expect :: Parser bc t (Maybe a) -> Parser bc t a+ -- | Immediately fail a parse. Equivalent to @'Expect' ('pure' 'Nothing')@.+ --+ -- @since 0.1.0.0+ Fail :: Parser bc t a+ deriving (Semigroup, Monoid) via (Ap (Parser bc t) a)++instance Show (Parser bc t a) where+ show (Pure _) = "(Pure _)"+ show (LiftA2 _ pa' pa_bctc) =+ "(LiftA2 _ " <> show pa' <> " " <> show pa_bctc <> ")"+ show GetCrumbs = "GetCrumbs"+ show (Target _ pa') = "(Target _ " <> show pa' <> "')"+ show (OnChildren pa') = "(OnChildren " <> show pa' <> ")"+ show Current = "Current"+ show (Expect pa') = "(Expect " <> show pa' <> ")"+ show Fail = "Fail"+++instance Functor (Parser bc t) where+ fmap = liftA++instance Applicative (Parser bc t) where+ pure = Pure+ liftA2 f (Pure a) (Pure b) = Pure $ f a b+ liftA2 _ Fail _ = Fail+ liftA2 _ _ Fail = Fail+ liftA2 f a b = LiftA2 f a b++instance Alternative (Parser bc t) where+ empty = Fail+ pa1 <|> pa2 =+ expect $ maybe <$> try pa2 <*> pure Just <*> try pa1++instance Selective (Parser bc t) where+ select = selectA++instance Filterable (Parser bc t) where+ catMaybes = Expect++instance Profunctor (Parser bc) where+ lmap = mapTree+ rmap = fmap+++------------------------------------------------------------------------------+-- | Transform the type of tree that a 'Parser' operates over.+--+-- @since 0.1.0.0+mapTree :: (t -> t') -> Parser bc t' a -> Parser bc t a+mapTree _ (Pure a) = Pure a+mapTree t (LiftA2 f pa pb) = LiftA2 f (mapTree t pa) (mapTree t pb)+mapTree _ GetCrumbs = GetCrumbs+mapTree t (Target p pa) = Target (p . t) $ mapTree t pa+mapTree t (OnChildren pa) = OnChildren $ mapTree t pa+mapTree t Current = fmap t Current+mapTree t (Expect pa) = Expect $ mapTree t pa+mapTree _ Fail = Fail+++------------------------------------------------------------------------------+-- | A parser to run on children, and a subsequent continuation for how to+-- parse the parent.+--+-- @since 0.1.0.0+data Split bc t a where+ Split+ :: Parser bc t a+ -- ^ The parser to run on children.+ -> ([a] -> Parser bc t b)+ -- ^ Continuation for how to subsequently parse the current node.+ -> Split bc t b+++------------------------------------------------------------------------------+-- | Swallow a parsed 'Maybe', failing the parser if it was 'Nothing'.+--+-- Use 'try' or 'optional' as the inverse to this parser.+--+-- @since 0.1.0.0+expect :: Parser bc t (Maybe a) -> Parser bc t a+expect (Pure Nothing) = Fail+expect (Pure (Just a)) = Pure a+expect p = Expect p+++------------------------------------------------------------------------------+-- | Like 'optional', but slightly more efficient.+--+-- @since 0.1.0.0+try :: Parser bc t a -> Parser bc t (Maybe a)+try Fail = pure Nothing+try (Expect p) = p+try (LiftA2 f a b) = LiftA2 (liftA2 f) (try a) (try b)+try p = fmap Just p+
+ test/Spec.hs view
@@ -0,0 +1,268 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Control.Selective+import Data.Bifunctor (bimap)+import Data.Foldable (traverse_)+import Data.Int (Int8)+import Data.Monoid (Any)+import Data.Set (Set)+import GHC.Generics (Generic)+import Lasercutter+import Lasercutter.Types+import Test.QuickCheck+import Test.QuickCheck.Checkers hiding (Test)+import Test.QuickCheck.Classes+++type Test = Parser (Set Four) DebugTree+++main :: IO ()+main = do+ traverse_ quickCheck+ [ -- expect is a left identity to optional+ property $ expect . optional =-= id @(Test Int8)++ , -- optional is a left identity to expect+ property $ optional . expect =-= id @(Test (Maybe Int8))++ , -- expect nothing is equivalent to fail+ property $ expect (pure Nothing) =-= (Fail :: Test Int8)++ -- expect distributes over liftA2+ , property $ \(f :: Int8 -> Four -> Bool) a b ->+ expect (liftA2 (liftA2 f) a b) =-= liftA2 @Test f (expect a) (expect b)++ -- optional equivalent to try+ , property $ optional @(Test) @Int8 =-= try+ ]++ quickBatch $ functor $ undefined @_ @(Test (Int8, Int8, Int8))+ quickBatch $ applicative $ undefined @_ @(Test (Int8, Int8, Int8))+ quickBatch $ selective $ undefined @_ @(Test (Int8, Int8, Int8))+ quickBatch $ alternative $ undefined @_ @(Test Int8)+ quickBatch $ semigroup $ undefined @_ @(Test Any, Int8)+ quickBatch $ monoid $ undefined @_ @(Test Any)+++------------------------------------------------------------------------------++instance {-# OVERLAPPABLE #-}+ ( CoArbitrary t+ , Arbitrary a+ , Arbitrary bc+ , CoArbitrary bc+ , CoArbitrary a+ ) =>+ Arbitrary (Parser bc t a)+ where+ arbitrary+ = let terminal+ = [ Pure <$> arbitrary+ , pure Fail+ ]+ in sized $ \ n ->+ case n <= 1 of+ True -> oneof terminal+ False -> oneof $+ [ liftA2+ <$> (arbitrary @(bc -> Int8 -> a))+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , liftA2+ <$> (arbitrary @(Bool -> Bool -> a))+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , liftA2+ <$> (arbitrary @(a -> a -> a))+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , fmap <$> arbitrary <*> pure Current+ , expect <$> scale (subtract 1) arbitrary+ ] <> terminal+ shrink (Pure a) = Fail : (fmap Pure $ shrink a)+ shrink GetCrumbs = [Fail]+ shrink (LiftA2 _ _ _) = [Fail]+ shrink (Target _ pa') = Fail : (pure $ fmap pure pa')+ shrink (OnChildren pa') = Fail : (pure $ fmap pure pa')+ shrink Current = [Fail]+ shrink (Expect pa') = Fail : (fmap expect $ shrink pa')+ shrink Fail = []+++instance+ ( CoArbitrary t+ , Arbitrary a+ , Arbitrary (Parser bc t a)+ , CoArbitrary bc+ , CoArbitrary a+ , Arbitrary bc+ ) =>+ Arbitrary (Parser bc t [a])+ where+ arbitrary+ = let terminal+ = [ Pure <$> arbitrary+ , pure Fail+ ]+ in sized $ \ n ->+ case n <= 1 of+ True -> oneof terminal+ False -> oneof $+ [ liftA2+ <$> arbitrary @(bc -> Int8 -> [a])+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , liftA2+ <$> arbitrary @(Bool -> Bool -> [a])+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , liftA2+ <$> arbitrary @(a -> a -> [a])+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , fmap <$> arbitrary <*> pure Current+ , Target <$> arbitrary <*> scale (subtract 1) arbitrary+ , OnChildren <$> scale (subtract 1) arbitrary+ , expect <$> scale (subtract 1) arbitrary+ ] <> terminal+ shrink (Pure a) = Fail : (fmap Pure $ shrink a)+ shrink Current = [Fail]+ shrink GetCrumbs = [Fail]+ shrink (LiftA2 _ _ _) = [Fail]+ shrink (Target _ pa') = Fail : (pure $ fmap pure pa')+ shrink (OnChildren pa') = Fail : (pure $ fmap pure pa')+ shrink (Expect pa') = Fail : (fmap expect $ shrink pa')+ shrink Fail = []+++instance+ ( CoArbitrary t+ , Arbitrary a+ , Arbitrary (Parser bc t a)+ , CoArbitrary bc+ , CoArbitrary a+ , Arbitrary bc+ ) =>+ Arbitrary (Parser bc t (Maybe a))+ where+ arbitrary+ = let terminal+ = [ Pure <$> arbitrary+ , pure Fail+ ]+ in sized $ \ n ->+ case n <= 1 of+ True -> oneof terminal+ False -> oneof $+ [ liftA2+ <$> arbitrary @(bc -> Int8 -> Maybe a)+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , liftA2+ <$> arbitrary @(Bool -> Bool -> Maybe a)+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , liftA2+ <$> arbitrary @(a -> a -> Maybe a)+ <*> scale (flip div 2) arbitrary+ <*> scale (flip div 2) arbitrary+ , fmap <$> arbitrary <*> pure Current+ , try <$> scale (subtract 1) arbitrary+ , expect <$> scale (subtract 1) arbitrary+ ] <> terminal+ shrink (Pure a) = Fail : (fmap Pure $ shrink a)+ shrink GetCrumbs = [Fail]+ shrink Current = [Fail]+ shrink (LiftA2 _ _ _) = [Fail]+ shrink (Expect pa') = Fail : (fmap expect $ shrink pa')+ shrink Fail = []+++------------------------------------------------------------------------------++data Four = A | B | C | D+ deriving (Eq, Ord, Show, Enum, Bounded, Generic)++instance Arbitrary Four where+ arbitrary = elements $ enumFromTo minBound maxBound++instance CoArbitrary Four++instance EqProp Four+++------------------------------------------------------------------------------++data DebugTree+ = Leaf Int8+ | Branch Four [DebugTree]+ deriving (Eq, Ord, Show, Generic)++instance Arbitrary DebugTree where+ arbitrary+ = let terminal = [Leaf <$> arbitrary]+ in sized $ \ n ->+ case n <= 1 of+ True -> oneof terminal+ False -> oneof $+ [ Branch <$> arbitrary <*> scale (flip div 2) arbitrary+ ] <> terminal++instance CoArbitrary DebugTree++instance EqProp DebugTree++instance IsTree DebugTree where+ getChildren (Leaf _) = []+ getChildren (Branch _ x) = x+++------------------------------------------------------------------------------++instance (EqProp a) => EqProp (Parser (Set Four) DebugTree a) where+ p1 =-= p2 = property $ do+ t <- arbitrary+ f <- arbitrary+ pure $ runParser f t p1 =-= runParser f t p2+++------------------------------------------------------------------------------++instance EqProp Int8 where+ (=-=) = (===)+++------------------------------------------------------------------------------++selective :: forall m a b c.+ ( Selective m+ , Arbitrary a, Arbitrary b+ , Arbitrary (m (Either a a)), Show (m (Either a a))+ , Arbitrary (m (Either a b)), Show (m (Either a b))+ , Arbitrary (m (Either c (a -> b))), Show (m (Either c (a -> b)))+ , Arbitrary (m (a -> b)), Show (m (a -> b))+ , Arbitrary (m (c -> a -> b)), Show (m (c -> a -> b))+ , Show a, Show b+ , EqProp (m a), EqProp (m b)+ ) =>+ m (a,b,c) -> TestBatch+selective = const ( "selective"+ , [ ("identity" , property identityP)+ , ("distributivity" , property distributivityP)+ , ("associativity", property associativityP)+ ]+ )+ where+ identityP :: m (Either a a) -> Property+ distributivityP :: Either a b -> m (a -> b) -> m (a -> b) -> Property+ associativityP :: m (Either a b) -> m (Either c (a -> b)) -> m (c -> a -> b) -> Property++ identityP x = (x <*? pure id) =-= fmap (either id id) x+ distributivityP x y z = (pure x <*? (y *> z)) =-= ((pure x <*? y) *> (pure x <*? z))+ associativityP x y z = (x <*? (y <*? z)) =-= ((fmap Right <$> x) <*? (g <$> y) <*? (uncurry <$> z))+ where+ g y' a = bimap (,a) ($a) y'+