diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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
+
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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.
+
+
+
+
+
+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
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/bench/HTML.hs b/bench/HTML.hs
new file mode 100644
--- /dev/null
+++ b/bench/HTML.hs
@@ -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
+
diff --git a/bench/Main.hs b/bench/Main.hs
new file mode 100644
--- /dev/null
+++ b/bench/Main.hs
@@ -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)
+ ]
+
diff --git a/bench/ScalpelSkipScript.hs b/bench/ScalpelSkipScript.hs
new file mode 100644
--- /dev/null
+++ b/bench/ScalpelSkipScript.hs
@@ -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
diff --git a/lasercutter.cabal b/lasercutter.cabal
new file mode 100644
--- /dev/null
+++ b/lasercutter.cabal
@@ -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
+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
diff --git a/src/Lasercutter.hs b/src/Lasercutter.hs
new file mode 100644
--- /dev/null
+++ b/src/Lasercutter.hs
@@ -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
+
diff --git a/src/Lasercutter/Internal.hs b/src/Lasercutter/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Lasercutter/Internal.hs
@@ -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
+
diff --git a/src/Lasercutter/Types.hs b/src/Lasercutter/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Lasercutter/Types.hs
@@ -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
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -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'
+