cassette 0.1.0 → 0.2.0

raw patch · 13 files changed

+816/−327 lines, 13 filesdep +profunctorssetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: profunctors

API changes (from Hackage documentation)

Files

• CHANGELOG.md +47/−0
• LICENSE +199/−24
• README.md +5/−0
• Setup.lhs +0/−3
• cassette.cabal +36/−26
• src/Control/Lens.hs +75/−0
• src/Text/Cassette.hs +62/−51
• src/Text/Cassette/Char.hs +40/−19
• src/Text/Cassette/Combinator.hs +42/−37
• src/Text/Cassette/Internal/Tr.hs +51/−0
• src/Text/Cassette/Lead.hs +116/−62
• src/Text/Cassette/Number.hs +13/−8
• src/Text/Cassette/Prim.hs +130/−97

@@ -0,0 +1,47 @@+# Changelog++## [0.2] - 2025-06-20++### Added++- `sscanf` and `sprintf`.+- `unitL`, the unique lead for the unit type.+- `NullL` type synonym for leads and other synonyms for higher arity.+- Support for lifting isos and prisms from [lens][lens] to leads.+- Examples to documentation.+- Flakification.+- Direnv support.++### Changed++- Types accumulate in the correct order when composing cassettes.+- `K7` has two type parameters, down from four. The parser and printer+  types are kept in sync.+- `K7` generalized to arbitrary profunctors.+- Make `K7` an instance of `Data.Monoid`. `mempty` signifies failure+  and `(<>)` is for alternation, instead of `(<|>)`.+- Swapped the order of the fields in `K7`.+- `many1` is now called `some` to be consistent with+  `Control.Applicative`.+- Change parameter order in `UnL`, `BinL` to match the order in+  [lens][lens].+- Switched to Apache-2.0 license.++### Fixed++- `choice` works when applied to the empty list.+- `nilL`, `nothingL` now correctly fail when the input is not the+  expected constructor.+- Argument to failure continuation in `consL`.++### Removed++- Chaining combinators `catanal`, `catanar` and `chainl`, `chainr`.++## [0.1] - 2012-03-19++Initial release.++[lens]: https://hackage.haskell.org/package/lens+[0.1]: https://github.com/mboes/cassette/releases/tag/v0.1+[0.2]: https://github.com/mboes/cassette/releases/tag/v0.2

@@ -1,27 +1,202 @@-Copyright (c) 2012 Mathieu Boespflug -All rights reserved.+                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/ -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.-3. Neither the name of the author nor the names of his contributors-   may be used to endorse or promote products derived from this software-   without specific prior written permission.+   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.+   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.

@@ -0,0 +1,5 @@+# Cassette++[![Hackage](https://img.shields.io/hackage/v/cassette.svg)](https://hackage.haskell.org/package/cassette)++Define a parser. Play it in reverse to get a pretty printer.

@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain

@@ -1,28 +1,38 @@-Name:           cassette-Version:        0.1.0-Author:         Mathieu Boespflug-Maintainer:     Mathieu Boespflug <mboes@cs.mcgill.ca>-Synopsis:       A combinator library for simultaneously defining parsers and pretty printers.-Description:-    Combinator library for defining both type safe parsers and pretty printers simultaneously.-    This library performs well in practice because parsers and printers are implemented in CPS-    and because arguments are always curried, rather than packed into nested tuples.-Category:       Parsing, Text-License:        BSD3-License-File:   LICENSE-Cabal-Version:  >= 1.10.0-Build-Type:     Simple-Tested-With:    GHC == 7.4.1+name: cassette+version: 0.2.0+author: Mathieu Boespflug+maintainer: Mathieu Boespflug <m@boespfl.ug>+synopsis: A combinator library for simultaneously defining parsers and pretty printers.+category: Parsing, Text+license: Apache-2.0+license-file: LICENSE+bug-reports: https://github.com/mboes/cassette/issues+cabal-version: 1.18.0+build-type: Simple +extra-doc-files:+  CHANGELOG.md+  README.md++source-repository head+  type:     git+  location: https://github.com/mboes/cassette+ library-  Hs-Source-Dirs: src-  Build-Depends:  base >= 4 && < 5-  Default-Language:     Haskell2010-  default-extensions:   RankNTypes-  other-extensions:     ImpredicativeTypes-  Exposed-Modules:      Text.Cassette-                        Text.Cassette.Prim-                        Text.Cassette.Lead-                        Text.Cassette.Combinator-                        Text.Cassette.Char-                        Text.Cassette.Number+  hs-source-dirs: src+  build-depends:+    base >= 4 && < 5,+    profunctors >= 5+  default-language: Haskell2010+  default-extensions: ImportQualifiedPost+  ghc-options: -Wall -Wno-name-shadowing+  exposed-modules:+    Text.Cassette+    Text.Cassette.Char+    Text.Cassette.Combinator+    Text.Cassette.Internal.Tr+    Text.Cassette.Lead+    Text.Cassette.Number+    Text.Cassette.Prim+  other-modules:+    Control.Lens

@@ -0,0 +1,75 @@+{-# LANGUAGE RankNTypes #-}++-- | Minimal re-implementation of just enough of lens, in order to avoid the+-- dependency. This is for INTERNAL USE ONLY. In downstream code, use lens or+-- any optics library.+module Control.Lens+  ( -- * Lenses+    Lens+  , view+    -- * Isomorphisms+  , Iso+  , iso+  , from+    -- * Prisms+  , Prism+  , preview+  , review+  ) where++import Data.Bifunctor (first)+import Data.Coerce (coerce)+import Data.Functor.Const (Const(..))+import Data.Functor.Identity (Identity(..))+import Data.Profunctor (Profunctor(..))+import Data.Profunctor.Unsafe ((#.))+import Data.Profunctor.Choice (Choice(..))++type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t++type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)++type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)++view :: Lens s t a b -> s -> a+view l s = getConst (l Const s)++data Market a b s t = Market (b -> t) (s -> Either t a)++instance Profunctor (Market a b) where+  dimap f g (Market bt seta) = Market (g . bt) (first g . seta . f)++instance Choice (Market a b) where+  right' (Market bt seta) = Market bt' seta'+    where+      bt' b           = Right (bt b)+      seta' (Left c)  = Left (Left c)+      seta' (Right s) = either (Left . Right) Right (seta s)++withPrism+  :: Prism s t a b+  -> ((b -> t) -> (s -> Either t a) -> r)+  -> r+withPrism k f = case coerce (k (Market Identity Right)) of+  Market bt seta -> f bt seta++review :: Prism s t a b -> b -> t+review p = withPrism p $ \build _ -> build++preview :: Prism s t a b -> s -> Maybe a+preview p = withPrism p $ \_ match -> either (const Nothing) Just . match++data Exchange a b s t = Exchange (s -> a) (b -> t)++instance Profunctor (Exchange a b) where+  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)++iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso sa bt = dimap sa (fmap bt)++withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r+withIso l k = case l (Exchange id Identity) of+  Exchange sa bt -> k sa (runIdentity #. bt)++from :: Iso s t a b -> Iso b a t s+from l = withIso l $ \sa bt -> iso bt sa

@@ -1,62 +1,73 @@ -- | The combinators of this library are all pairs of functions going in--- opposite directions. These pairs are called /cassettes/, sporting two--- tracks (the two functions), one of which is read is one direction, the--- other of which (accessed by flipping the cassette) is read in the opossite--- direction.+-- opposite directions. These pairs are called /cassettes/, sporting two tracks+-- (the two functions), one of which is read in one direction, the other of+-- which (accessed by flipping the cassette) is read in the opposite direction. ----- Here is an example specification for the lambda-calculus:+-- = __Example__ ----- > varL = K7 leadout leadin where--- >   leadout k k' s x = k (\ s _ -> k' s x) s (Var x)--- >   leadin k k' s t@(Var x)  = k (\ s _ -> k' s t) s x--- >   leadin k k' s t          = k' s t--- >--- > absL = K7 leadout leadin where--- >   leadout k k' s t' x = k (\ s _ -> k' s t' x) s (Lam x t')--- >   leadin k k' s t@(Lam x t)  = k (\ s _ _ -> k' s t) s t x--- >   leadin k k' s t            = k' s t--- >--- > appL = K7 leadout leadin where--- >   leadout k s t2 t1 = k (\ s _ -> k' s t2 t1) s (App t1 t2)--- >   leadin k k' s t@(App t1 t2)  = k (\ s _ _ -> k' s t) s t2 t1--- >   leadin k k' s t            = k' s t--- >--- > parens p = char '(' <> p <> char ')'--- >--- > term :: PP Term--- > term  =   varL --> ident--- >       <|> absL --> char '\' <> ident <> term--- >       <|> appL --> parens (term <> sepSpace <> term)+-- Consider the data type for abstract syntax trees of the λ-calculus: ----- From this single specification, we can extract a parser,+-- >>> :{+--   type Ident = String+--   data Term where+--     Var :: Ident -> Term+--     Abs :: Ident -> Term -> Term+--     App :: Term -> Term -> Term+--   deriving instance Show Term+--   makePrisms ''Term+-- :} ----- > parse term :: PP Term -> String -> Maybe Term+-- Given a few constructor-wrapping prisms (generated by @makePrisms@ from the+-- lens library or otherwise) and lifting them to cassette /leads/ (the+-- definitions are mechanical), ... ----- and also a pretty printer,+-- >>> :{+--   varL = prismL _Var+--   absL = prismL _Abs . pairL+--   appL = prismL _App . pairL+-- :} ----- > pretty term :: PP Term -> Term -> Maybe String+-- ... the concrete syntax for terms of the λ-calculus can be defined+-- as follows: ----- Specifications are built from primitive and derived combinators, which--- affect the input string in some way. For each constructor of each datatype,--- we need to write a /lead/, which is a pair of a construction function and a--- destruction function. Leads are pure combinators that do not affect the--- input string. By convention, we suffix their name with "L".+-- >>> :{+--   term :: PP Term+--   term =+--     varL --> ident <>+--     absL --> char '^' . ident . char '.' . optSpace . term <>+--     appL --> parens (term . sepSpace . term)+--   parens p = char '(' . p . char ')'+--   ident = consL --> letter . many alphaNum+-- :} ----- Internally, the primitive combinators are written in CPS. Leads also need--- to be written in this style, being primitive. They can, however, be--- automatically generated for every datatype using some Template Haskell--- hackery (in a separate package). A number of leads for standard datatypes--- are defined in the 'Text.Cassette.Lead' module.+-- From this single specification, we can extract a parser, using+-- 'parse', and also a pretty printer, using 'pretty'.+--+-- >>> parse term "^x. (x x)"+-- Just (Abs "x" (App (Var "x") (Var "x")))+--+-- >>> pretty term (Abs "x" (App (Var "x") (Var "x")))+-- Just "^x. (x x)"+--+-- = Grammar specifications+--+-- Specifications are built from primitive and derived combinators, which affect+-- the input string in some way. For each constructor of each datatype, we need+-- to write a /lead/, which is a pair of a construction function and+-- a destruction function. Leads are pure combinators that do not affect the+-- input string. By convention, we suffix their name with "L". A number of leads+-- for standard data types are defined in the "Text.Cassette.Lead" module. -module Text.Cassette-       ( module Text.Cassette.Prim-       , module Text.Cassette.Lead-       , module Text.Cassette.Combinator-       , module Text.Cassette.Char-       , module Text.Cassette.Number ) where+module Text.Cassette (module X) where -import Text.Cassette.Prim-import Text.Cassette.Lead-import Text.Cassette.Combinator-import Text.Cassette.Char-import Text.Cassette.Number+import Prelude hiding ((.))+import Text.Cassette.Char as X+import Text.Cassette.Combinator as X+import Text.Cassette.Lead as X+import Text.Cassette.Number as X+import Text.Cassette.Prim as X++-- $setup+-- >>> :seti -XStandaloneDeriving -XGADTSyntax+-- >>> import Control.Category+-- >>> import Control.Lens.TH

@@ -1,9 +1,14 @@+{-# LANGUAGE RankNTypes #-}++-- | Commonly used character-oriented combinators.+ module Text.Cassette.Char where -import Text.Cassette.Prim-import Text.Cassette.Combinator+import Control.Category ((.)) import Data.Char-+import Prelude hiding ((.))+import Text.Cassette.Combinator+import Text.Cassette.Prim  -- | Succeeds if the current character is in the supplied list of characters. -- See also 'satisfy'.@@ -16,47 +21,63 @@ noneOf :: [Char] -> PP Char noneOf xs = satisfy (not . (`elem` xs)) --- | The 'satisfy' combinator, unshifted.+-- | The 'satisfy' combinator, but unset. skip :: (Char -> Bool) -> Char -> PP0-skip p x = unshift x $ satisfy p+skip p x = unset x $ satisfy p  -- The next three combinators take their specification from the -- invertible-syntax package. --- | 'skipSpace' marks a position where whitespace is allowed to--- occur. It accepts arbitrary space while parsing, and produces--- no space while printing.+-- | 'skipSpace' marks a position where whitespace is allowed to occur. It+-- accepts arbitrary space while parsing, and produces no space while printing. skipSpace :: PP0-skipSpace = unshift "" $ many (satisfy isSpace)+skipSpace = unset "" $ many (satisfy isSpace) --- | 'optSpace' marks a position where whitespace is desired to occur.--- It accepts arbitrary space while parsing, and produces a--- single space character while printing.+-- | 'optSpace' marks a position where whitespace is desired to occur. It+-- accepts arbitrary space while parsing, and produces a single space character+-- while printing. optSpace :: PP0-optSpace = unshift " " $ many (satisfy isSpace)+optSpace = unset " " $ many (satisfy isSpace) --- | 'sepSpace' marks a position where whitespace is required to--- occur. It requires one or more space characters while parsing,--- and produces a single space character while printing.+-- | 'sepSpace' marks a position where whitespace is required to occur. It+-- requires one or more space characters while parsing, and produces a single+-- space character while printing. sepSpace :: PP0-sepSpace = string " " <> skipSpace+sepSpace = space . skipSpace --- | Parses a newline character (\'\\n\').+-- | A single space character (\' \').+space :: PP0+space = char ' '++-- | A single newline character (\'\\n\'). newline :: PP0 newline = char '\n' --- | Parses a tab character (\'\\t\').+-- | A single tab character (\'\\t\'). tab :: PP0 tab = char '\t'  upper, lower, alphaNum, letter, digit, hexDigit, octDigit, anyChar :: PP Char +-- | An upper-case Unicode character. upper = satisfy isUpper++-- | A lower-case Unicode character. lower = satisfy isLower++-- | An alphabetic or numeric Unicode character. alphaNum = satisfy isAlphaNum++-- | An alphabetic Unicode character. letter = satisfy isAlpha++-- | An ASCII digit. digit = satisfy isDigit++-- | An ASCII hexadecimal digit. hexDigit = satisfy isHexDigit++-- | An ASCII octal digit. octDigit = satisfy isOctDigit  -- | Any character.

@@ -1,89 +1,94 @@-{-# LANGUAGE RankNTypes, ImpredicativeTypes #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE RankNTypes #-}++-- | Commonly used generic combinators.+ module Text.Cassette.Combinator where -import Text.Cassette.Prim+import Control.Category ((.))+import Prelude hiding ((.)) import Text.Cassette.Lead-+import Text.Cassette.Prim  -- | Applies each cassette in the supplied list in order, until one of them -- succeeds. choice :: [PP a] -> PP a-choice [p] = p-choice (p:ps) = p <|> choice ps+choice [] = mempty+choice (p:ps) = p <> choice ps  -- | @count n p@ matches @n@ occurrences of @p@. count :: Int -> PP a -> PP [a] count 0 _ = nilL-count n p = consL --> p <> count (n - 1) p+count n p = consL --> p . count (n - 1) p --- | Tries to apply the given cassette. It returns the value of the cassette--- on success, the first argument otherwise.+-- | Tries to apply the given cassette. It returns the value of the cassette on+-- success, the first argument otherwise. option :: a -> PP a -> PP a-option x p = p <|> shift x nothing+option x p = p <> set x nothing --- | Tries to apply the given cassette. It returns a value of the form @Just--- x@ on success, @Nothing@ otherwise.+-- | Tries to apply the given cassette. It returns a value of the form @Just x@+-- on success, @Nothing@ otherwise. optionMaybe :: PP a -> PP (Maybe a)-optionMaybe p = justL --> p <|> nothingL+optionMaybe p = justL --> p <> nothingL  -- | Tries to match the given cassette and discards the result, otherwise does -- nothing in case of failure. optional :: PP a -> PP0-optional p = unshift [] (count 1 p <|> count 0 p)+optional p = unset [] (count 1 p <> count 0 p)  -- | Apply the given cassette zero or more times. many :: PP a -> PP [a]-many p = many1 p <|> nilL+many p = some p <> nilL  -- | Apply the given cassette one or more times.-many1 :: PP a -> PP [a]-many1 p = consL --> p <> many p+some :: PP a -> PP [a]+some p = consL --> p . many p  -- | Apply the given cassette zero or more times, discarding the result. skipMany :: PP a -> PP0-skipMany p = unshift [] $ many p+skipMany p = unset [] $ many p  -- | Apply the given cassette one or more times, discarding the result.-skipMany1 :: PP a -> PP0-skipMany1 p = unshift [] $ many1 p+skipSome :: PP a -> PP0+skipSome p = unset [] $ some p  -- | Apply the first argument zero or more times, separated by the second -- argument. sepBy :: PP a -> PP0 -> PP [a]-sepBy px psep = sepBy1 px psep <|> nilL+sepBy px psep = sepBy1 px psep <> nilL  -- | Apply the first argument one or more times, separated by the second -- argument. sepBy1 :: PP a -> PP0 -> PP [a]-sepBy1 px psep = consL --> px <> many (psep <> px)+sepBy1 px psep = consL --> px . many (psep . px) --- | @chainl p op x@ matches zero or more occurrences of @p@, separated by--- @op@. Returns a value obtained by a /left associative/ application of all--- functions returned by @op@ to the values returned by @p@. If there are zero--- occurrences of @p@, the value @x@ is returned.+-- | @chainl p op x@ matches zero or more occurrences of @p@, separated by @op@.+-- Returns a value obtained by a /left associative/ application of all functions+-- returned by @op@ to the values returned by @p@. If there are zero occurrences+-- of @p@, the value @x@ is returned. chainl :: PP0 -> BinL a a a -> PP a -> a -> PP a-chainl opP opL xP dflt = chainl1 opP opL xP <|> shift dflt nothing+chainl opP opL xP dflt = chainl1 opP opL xP <> set dflt nothing --- | Match a a left-associative chain of infix operators.+-- | Match a left-associative chain of infix operators. chainl1 :: PP0 -> BinL a a a -> PP a -> PP a-chainl1 opP opL xP = catanal opL --> xP <> many (opP <> xP)+chainl1 opP opL xP = catanal opL --> xP . many (opP . xP) --- | @chainr p op x@ matches zero or more occurrences of @p@, separated by--- @op@. Returns a value obtained by a /right associative/ application of all+-- | @chainr p op x@ matches zero or more occurrences of @p@, separated by @op@.+-- Returns a value obtained by a /right associative/ application of all -- functions returned by @op@ to the values returned by @p@. If there are zero -- occurrences of @p@, the value @x@ is returned. chainr :: PP0 -> BinL a a a -> PP a -> a -> PP a-chainr opP opL xP dflt = chainr1 opP opL xP <|> shift dflt nothing+chainr opP opL xP dflt = chainr1 opP opL xP <> set dflt nothing --- | Match a a right-associative chain of infix operators.+-- | Match a right-associative chain of infix operators. chainr1 :: PP0 -> BinL a a a -> PP a -> PP a-chainr1 opP opL xP = catanar opL --> xP <> many (opP <> xP)+chainr1 opP opL xP = catanar opL --> xP . many (opP . xP) --- | @notFollowedBy p@ only succeeds when @p@ fails. This combinator does--- not consume/produce any input.+-- | @notFollowedBy p@ only succeeds when @p@ fails. This combinator does not+-- consume\/produce any input. notFollowedBy :: PP0 -> PP0-notFollowedBy p = unshift () $ shift () (p <> empty) <|> shift () nothing+notFollowedBy p = unset () $ set () (p . mempty) <> set () nothing  -- | Applies first argument zero or more times until second argument succeeds. manyTill :: PP a -> PP0 -> PP [a]-manyTill xP endP = nilL --> endP <|> consL --> xP <> manyTill xP endP+manyTill xP endP = nilL --> endP <> consL --> xP . manyTill xP endP

@@ -0,0 +1,51 @@+{-# LANGUAGE BlockArguments #-}++module Text.Cassette.Internal.Tr where++import Control.Category (Category(..))+import Prelude hiding (flip, id, (.))++-- | The type of string transformers in CPS, /i.e./ functions from strings to+-- strings.+type C r = (String -> r) -> String -> r++-- | @'Tr' r r'@ is the type of string transformers with answer type+-- modification from @r@ to @r'@ through control effects.+newtype Tr r r' = Tr { unTr :: C r -> C r' }++instance Category Tr where+  id = Tr id+  Tr f . Tr g = Tr (f . g)++-- | '(<>)' is the choice operator. Note that this is an unrestricted+-- backtracking operator: it never commits to any particular choice.+instance Semigroup (Tr r r') where+  Tr f <> Tr g = Tr \k k' s -> f k (\_ -> g k k' s) s++-- | 'mempty' is the string transformer that always fails.+instance Monoid (Tr r r') where+  mempty = Tr \_ k' s -> k' s++-- | Capture continuation up to the closest 'reset'.+shift :: (C r -> Tr w r') -> Tr r r'+shift f = Tr \k -> unTr (f k) id++-- | Inverse of 'shift'.+plug :: C r -> Tr r r' -> Tr w r'+plug k (Tr f) = Tr \_ -> f k++-- | Replace the success continuation.+replace :: C r -> Tr w r+replace k = plug k id++pushNeg :: a -> Tr (a -> r) r+pushNeg x = shift \k -> replace \k' s -> k (\s _ -> k' s) s x++popNeg :: Tr r (a -> r)+popNeg = shift \k -> replace \k' s x -> k (\s -> k' s x) s++pushPos :: a -> Tr (r -> r') ((a -> r) -> r')+pushPos x = shift \k -> replace \k' s u -> k (\s _ -> k' s u) s (u x)++popPos :: Tr ((a -> r) -> r') (r -> r')+popPos = shift \k -> replace \k' s u -> k (\s _ -> k' s u) s (\_ -> u)

@@ -1,80 +1,134 @@ {-# LANGUAGE RankNTypes #-}+ module Text.Cassette.Lead where +import Control.Lens qualified as Lens+import Text.Cassette.Internal.Tr (Tr(..)) import Text.Cassette.Prim +-- | Nullary leads. Synonym to 'PP'.+type NullL s = forall r. K7 Tr r (s -> r) --- | The type of binary leads, parameterized by the type of the left operand,--- the right operand, and the type of the result.-type UnL a b =-  forall r r'. K7 (C (b -> r))  (C (a -> r))-                  (C (b -> r')) (C (a -> r'))+-- | Unary leads. A lead of type @'UnL' s a@ projects/injects a component @a@+-- from/into outer type @s@.+type UnL s a = forall r. K7 Tr (a -> r) (s -> r) --- | The type of binary leads, parameterized by the type of the left operand,--- the right operand, and the type of the result.-type BinL a b c =-  forall r r'. K7 (C (c -> r))  (C (b -> a -> r))-                  (C (c -> r')) (C (b -> a -> r'))+-- | Binary leads. A lead of type @'BinL' s a b@ projects/injects components+-- @a@, @b@ from/into outer type @s@.+type BinL s a b = forall r. K7 Tr (a -> b -> r) (s -> r) --- | Lift a pair of symmetric functions to a lead.-liftL :: Sym a b -> UnL a b-liftL (Sym (K7 f f')) =-  K7 (\k k' s x -> k (\s _ -> k' s x) s (f x))-     (\k k' s y -> k (\s _ -> k' s y) s (f' y))+-- | Ternary leads. A lead of type @'TernL' s a b c@ projects/injects components+-- @a@, @b@, @c@ from/into outer type @s@.+type TernL s a b c = forall r. K7 Tr (a -> b -> c -> r) (s -> r) --- | Iterates a one step construction function (resp. deconstruction)--- function, i.e. a lead, thus obtaining a right fold (resp. unfold). The--- resulting lead is a catamorphism on one side and an anamorpism on the--- other, hence the name. The type of this function is the same as that of--- 'foldr', lifted to cassettes.-catanar :: BinL a b b -> BinL b [a] b-catanar (K7 f f') = K7 g g' where-  g k k' s xs@[]      z = k (\s _ -> k' s xs z) s z-  g k k' s xs@(x:xs') z =-    g (\k' s z -> f k (\s _ _ -> k' s z) s z x) (\s _ _ -> k' s xs z) s xs' z-  g' k k' s z =-    f' (\k' s z x -> g' (\k' s xs' z -> k k' s (x:xs') z) (\s _ -> k' s z x) s z)-       (\s _ -> k (\s _ _ -> k' s z) s [] z) s z+-- | Quaternary leads. A lead of type @'QuaternL' s a b c d@ projects/injects+-- components @a@, @b@, @c@, @d@ from/into outer type @s@.+type QuaternL s a b c d = forall r. K7 Tr (a -> b -> c -> d -> r) (s -> r) --- | Iterates a one step construction function (resp. deconstruction)--- function, i.e. a lead, thus obtaining a left fold (resp. unfold). The--- resulting lead is a catamorphism on one side and an anamorpism on the--- other, hence the name. The type of this function is the same as that of--- 'foldl', lifted to cassettes.-catanal :: BinL a b a -> BinL a [b] a-catanal (K7 f f') = K7 g (g' []) where-  g k k' s xs@[]      z = k (\s _ -> k' s xs z) s z-  g k k' s xs@(x:xs') z =-    f (\k' s z -> g k (\s _ _ -> k' s z) s xs' z) (\s _ _ -> k' s xs z) s x z-  g' xs' k k' s z =-    f' (\k' s x z -> g' (x:xs') k (\s _ -> k' s x z) s z) (\s _ -> k (\s _ _ -> k' s z) s xs' z) s z+-- | Lift an isomorphism (see the+-- [lens](https://hackage.haskell.org/package/lens) library) to a lead.+isoL :: forall s a. Lens.Iso s s a a -> UnL s a+isoL l = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s t = k (\s _ -> k' s t) s (Lens.view l t)+    leadout k k' s u = k (\s _ -> k' s u) s (\x -> u (Lens.view (Lens.from l) x)) -consL :: BinL a [a] [a]-consL = K7 (\k k' s xs' x -> k (\s _ -> k' s xs' x) s (x:xs'))-           (\k k' s xs -> case xs of-               x:xs' -> k (\s _ _ -> k' s xs) s xs' x-               _ -> k' s xs)+-- | Lift a prism (see [lens](https://hackage.haskell.org/package/lens) library)+-- to a lead.+prismL :: Lens.Prism s s a a -> UnL s a+prismL l = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s t = case Lens.preview l t of+      Nothing -> k' s t+      Just x -> k (\s _ -> k' s t) s x+    leadout k k' s u = k (\s _ -> k' s u) s (\x -> u (Lens.review l x)) -nilL :: PP [a]-nilL = shift [] nothing+-- | Iterates a one step construction function (resp. deconstruction) function,+-- i.e. a lead, thus obtaining a right fold (resp. unfold). The resulting lead+-- is a catamorphism on one side and an anamorpism on the other, hence the name.+-- The type of this function is the same as that of 'foldr', lifted to+-- cassettes.+catanar :: BinL b a b -> BinL b b [a]+catanar _ = error "unimplemented"+-- catanar (K7 (Tr f) (Tr f')) = K7 (Tr g) (Tr g')+--   where+--     g k k' s xs@[]      z = k (\s _ -> k' s xs z) s z+--     g k k' s xs@(x:xs') z =+--       g (\k' s z -> f k (\s _ _ -> k' s z) s z x) (\s _ _ -> k' s xs z) s xs' z+--     g' k k' s z =+--       f' (\k' s z x -> g' (\k' s xs' z -> k k' s (x:xs') z) (\s _ -> k' s z x) s z) (\s _ -> k (\s _ _ -> k' s z) s [] z) s z -justL :: UnL a (Maybe a)-justL = K7 (\k k' s x -> k (\s _ -> k' s x) s (Just x))-           (\k k' s mb -> maybe (k' s mb) (k (\s _ -> k' s mb) s) mb)+-- | Iterates a one step construction function (resp. deconstruction) function,+-- i.e. a lead, thus obtaining a left fold (resp. unfold). The resulting lead is+-- a catamorphism on one side and an anamorpism on the other, hence the name.+-- The type of this function is the same as that of 'foldl', lifted to+-- cassettes.+catanal :: BinL a a b -> BinL a a [b]+catanal _ = error "unimplemented"+-- catanal (K7 (Tr f) (Tr f')) = K7 (Tr g) (Tr (g' []))+--   where+--     g k k' s xs@[]      z = k (\s _ -> k' s xs z) s z+--     g k k' s xs@(x:xs') z =+--       f (\k' s z -> g k (\s _ _ -> k' s z) s xs' z) (\s _ _ -> k' s xs z) s x z+--     g' xs' k k' s z =+--       f' (\k' s x z -> g' (x:xs') k (\s _ -> k' s x z) s z) (\s _ -> k (\s _ _ -> k' s z) s xs' z) s z +-- | '(:)' lead.+consL :: BinL [a] a [a]+consL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s xs@(x:xs') = k (\s _ _ -> k' s xs) s x xs'+    leadin _ k' s xs = k' s xs+    leadout k k' s u = k (\s _ -> k' s u) s (\x xs' -> u (x:xs'))++-- | '[]' lead.+nilL :: NullL [a]+nilL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s xs@[] = k (\s -> k' s xs) s+    leadin _ k' s xs = k' s xs+    leadout k k' s u = k (\s _ -> k' s u) s (u [])++-- | 'Just' lead.+justL :: UnL (Maybe a) a +justL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s mb@(Just x) = k (\s _ -> k' s mb) s x+    leadin _ k' s mb = k' s mb+    leadout k k' s u = k (\s _ -> k' s u) s (\x -> u (Just x))++-- | 'Nothing' lead. nothingL :: PP (Maybe a)-nothingL = shift Nothing nothing+nothingL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s mb@Nothing = k (\s -> k' s mb) s+    leadin _ k' s mb = k' s mb+    leadout k k' s u = k (\s _ -> k' s u) s (u Nothing) -pairL :: BinL a b (a, b)-pairL = K7 (\k k' s x2 x1 -> k (\s _ -> k' s x2 x1) s (x1, x2))-           (\k k' s t@(x1, x2) -> k (\s _ _ -> k' s t) s x2 x1)+-- | Construct/destruct the unit element.+unitL :: NullL ()+unitL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s t@() = k (\s -> k' s t) s+    leadout k k' s u = k (\s _ -> k' s u) s (u ()) -tripleL :: K7 (C ((a,b,c) -> r))  (C (c -> b -> a -> r))-              (C ((a,b,c) -> r')) (C (c -> b -> a -> r'))-tripleL = K7 (\k k' s x3 x2 x1 -> k (\s _ -> k' s x3 x2 x1) s (x1, x2, x3))-             (\k k' s t@(x1, x2, x3) -> k (\s _ _ _ -> k' s t) s x3 x2 x1)+-- | Construct/destruct a pair.+pairL :: BinL (a, b) a b+pairL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s t@(x1, x2) = k (\s _ _ -> k' s t) s x1 x2+    leadout k k' s u = k (\s _ -> k' s u) s (\x1 x2 -> u (x1, x2)) -quadrupleL :: K7 (C ((a,b,c,d) -> r))  (C (d -> c -> b -> a -> r))-                 (C ((a,b,c,d) -> r')) (C (d -> c -> b -> a -> r'))-quadrupleL = K7 (\k k' s x4 x3 x2 x1 -> k (\s _ -> k' s x4 x3 x2 x1) s (x1, x2, x3, x4))-                (\k k' s t@(x1, x2, x3, x4) -> k (\s _ _ _ _ -> k' s t) s x4 x3 x2 x1)+-- | Construct/destruct a 3-tuple.+tripleL :: TernL (a, b, c) a b c+tripleL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s t@(x1, x2, x3) = k (\s _ _ _ -> k' s t) s x1 x2 x3+    leadout k k' s u = k (\s _ -> k' s u) s (\x1 x2 x3 -> u (x1, x2, x3))++-- | Construct/destruct a 4-tuple.+quadrupleL :: QuaternL (a, b, c, d) a b c d+quadrupleL = K7 (Tr leadin) (Tr leadout)+  where+    leadin k k' s t@(x1, x2, x3, x4) = k (\s _ _ _ _ -> k' s t) s x1 x2 x3 x4+    leadout k k' s u = k (\s _ -> k' s u) s (\x1 x2 x3 x4 -> u (x1, x2, x3, x4))

@@ -1,14 +1,19 @@--- | This module exports combinators for parsing number literals.+-- | Combinators to handle number literals.+ module Text.Cassette.Number where -import Text.Cassette.Prim-import Text.Cassette.Lead-import Text.Cassette.Combinator+import Control.Category ((.))+import Control.Lens qualified as Lens+import Prelude hiding ((.)) import Text.Cassette.Char-+import Text.Cassette.Combinator+import Text.Cassette.Lead+import Text.Cassette.Prim  -- | An integer literal, positive or negative. int :: PP Int-int = intL --> many1 digit <|>-      intL --> consL --> satisfy (== '-') <> many1 digit-  where intL = liftL $ Sym $ K7 read show+int =+    intL --> some digit <>+    intL --> consL --> satisfy (== '-') . some digit+  where+    intL = isoL (Lens.iso show read)

@@ -1,138 +1,171 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-}++-- | The primitive parser combinators.+ module Text.Cassette.Prim-       ( -- * Datatypes-         K7(..), Sym(..), C, PP, PP0-         -- * Composition-       , (<>), (-->), (<|>)-         -- * Extraction-       , play, flip, parse, pretty-         -- * Primitive combinators-       , empty, nothing, shift, unshift, string, satisfy, lookAhead, eof-       ) where+  ( -- * Data types+    K7(..)+  , Tr+  , PP+  , PP0+    -- * Composition+  , (-->)+    -- * Extraction+  , parse+  , pretty+  , sscanf+  , sprintf+    -- * Primitive combinators+  , nothing+  , set+  , unset+  , string+  , satisfy+  , lookAhead+  , eof+  ) where +import Control.Category (Category(..)) import Data.List (stripPrefix)-import Control.Category+import GHC.Stack (HasCallStack) import Prelude hiding (flip, id, (.))-import qualified Prelude----- | A cassette consists of two tracks, represented by functions. The--- functions on each track are not necessarily inverses of each other, and do--- not necessarily connect the same start and end types.-data K7 a b c d = K7 { sideA :: a -> b, sideB :: d -> c }---- | Symmetric cassettes do have functions that are inverses of each other on--- each track. Symmetric cassettes form a category under splicing (see--- '(<>)').-newtype Sym a b = Sym { unSym :: K7 a b a b }+import Text.Cassette.Internal.Tr (Tr(..))+import Text.Cassette.Internal.Tr qualified as Tr -infixr 9 <>+-- | A cassette consists of two tracks, represented by profunctors. The second+-- track has its polarities flipped relative to the first.+data K7 p a b = K7+  { sideA :: p a b+  , sideB :: forall t. p (a -> t) (b -> t)+  } --- | Tape splicing operator. Functions on each track are composed pairwise.-(<>) :: K7 b c b' c' -> K7 a b a' b' -> K7 a c a' c'--- Irrefutable patterns to support definitions of combinators by coinduction.-~(K7 f f') <> ~(K7 g g') = K7 (f . g) (g' . f')+instance (forall r r'. Semigroup (p r r')) => Semigroup (K7 p r r') where+  K7 f f' <> K7 g g' = K7 (f <> g) (f' <> g') -instance Category Sym where-  id = Sym (K7 id id)-  Sym csst1 . Sym csst2 = Sym (csst1 <> csst2)+instance (forall r r'. Monoid (p r r')) => Monoid (K7 p r r') where+  mempty = K7 mempty mempty -infixr 8 -->+instance Category p => Category (K7 p) where+  id = K7 id id+  -- Irrefutable patterns to support definitions of combinators by coinduction.+  ~(K7 f f') . ~(K7 g g') = K7 (f . g) (f' . g') --- | A synonym to '(<>)' with its arguments flipped and with lower precedence.-(-->) = Prelude.flip (<>)+infixr 9 --> --- | The type of string transformers in CPS, /i.e./ functions from strings to--- strings.-type C r = (String -> r) -> String -> r+-- | A synonym to '(.)'+(-->) :: Category p => K7 p b c -> K7 p a b -> K7 p a c+(-->) = (.)  -- | The type of cassettes with a string transformer on each side. The A-side--- produces a value in addition to transforming the string, /i.e./ it is a--- parser. The B-side consumes a value to transform the string, /i.e./ it is a--- printer.-type PP a = forall r r'. K7 (C (a -> r)) (C r) (C (a -> r')) (C r')-type PP0  = forall r r'. K7 (C r) (C r) (C r') (C r')---- | Select the A-side.-play :: K7 a b c d -> a -> b-play csst = sideA csst+-- produces a value in addition to transforming the string, /i.e./ it is+-- a parser. The B-side consumes a value to transform the string, /i.e./ it is+-- a printer.+type PP a = forall r. K7 Tr r (a -> r) --- | Switch the A-side and B-side around.-flip :: K7 a b c d -> K7 d c b a-flip (K7 f g) = K7 g f+-- | The type of cassettes only useful for their effect on the input or output+-- strings, but do not produce\/consume any value.+type PP0 = forall r. K7 Tr r r  -- | Extract the parser from a cassette. parse :: PP a -> String -> Maybe a-parse csst = play csst (\_ _ x -> Just x) (const Nothing)+parse (K7 _ f') s = unTr f' (\_ _ x -> Just x) (\_ _ -> Nothing) s id  -- | Flip the cassette around to extract the pretty printer. pretty :: PP a -> a -> Maybe String-pretty csst = play (flip csst) (const Just) (\_ _ -> Nothing) ""---- Use same priority and associativity as in Parsec.-infixr 1 <|>+pretty (K7 f _) = unTr f (const Just) (\_ _ -> Nothing) "" --- | Choice operator. If the first cassette fails, then try the second parser.--- Note that this is an unrestricted backtracking operator: it never commits--- to any particular choice.-(<|>) :: PP a -> PP a -> PP a-K7 f f' <|> K7 g g' =-  K7 (\k k' s -> f k (\s' -> g k k' s) s)-     (\k k' s x -> f' k (\s' -> g' k k' s) s x)+-- | An equivalent to @sscanf()@ in C: @'sscanf' fmt k s@ extracts data from+-- string @s@ according to format descriptor @fmt@ and hands the data to+-- continuation @k@.+--+-- >>> spec = satisfy (=='A') . satisfy (=='B') . satisfy (=='C')+-- >>> sscanf spec "ABC" (,,)+-- ('A','B','C')+sscanf :: HasCallStack => K7 Tr r r' -> String -> r' -> r+sscanf (K7 _ f') = unTr f' (\_ _ -> id) (\_ _ -> error msg)+  where+    msg = "sscanf: formatting error" --- | Always fail.-empty :: PP0-empty = K7 (\k k' s -> k' s) (\k k' s -> k' s)+-- | An equivalent to @sprintf()@ in C: @'sprintf' fmt@ returns a function that+-- returns a string and whose number of arguments depends on format descriptor+-- @fmt@.+--+-- >>> spec = satisfy (=='A') . satisfy (=='B') . satisfy (=='C')+-- >>> sprintf spec 'A' 'B' 'C'+-- "ABC"+sprintf :: HasCallStack => K7 Tr String r -> r+sprintf (K7 f _) = unTr f (\_ -> id) (\_ -> error msg) ""+  where+    msg = "sprintf: formatting error"  -- | Do nothing.+--+-- >>> pretty (set () nothing) ()+-- Just "" nothing :: PP0-nothing = K7 id id+nothing = id --- | Turn the given pure transformer into a parsing/printing pair. That is,--- return a cassette that produces and output on the one side, and consumes an+-- | Turn the given pure transformer into a parsing\/printing pair. That is,+-- return a cassette that provides an output on the one side, and consumes an -- input on the other, in addition to the string transformations of the given--- pure transformer. @shift x p@ produces @x@ as the output of @p@ on the+-- pure transformer. @'set' x p@ provides @x@ as the output of @p@ on the -- parsing side, and on the printing side accepts an input that is ignored.-shift :: a -> PP0 -> PP a-shift x ~(K7 f f') =-  K7 (\k k' -> f (\k' s -> k (\s _ -> k' s) s x) k')-     (\k k' s x -> f' k (\s -> k' s x) s)+set :: a -> PP0 -> PP a+set x ~(K7 f f') = K7 (Tr.popNeg . f) (Tr.pushPos x . f') --- | Turn the given cassette into a pure string transformer. That is, return a--- cassette that does not produce an output or consume an input. @unshift x p@--- throws away the output of @p@ on the parsing side, and on the printing side--- sets the input to @x@.-unshift :: a -> PP a -> PP0-unshift x ~(K7 f f') =-  K7 (\k k' -> f (\k' s x -> k (\s -> k' s x) s) k')-     (\k k' s -> f' k (\s _ -> k' s) s x)+-- | Turn the given parsing\/printing pair into a pure string transformer. That+-- is, return a cassette that does not produce an output or consume an input.+-- @'unset' x p@ throws away the output of @p@ on the parsing side, and on the+-- printing side sets the input to @x@.+unset :: a -> PP a -> PP0+unset x ~(K7 f f') = K7 (Tr.pushNeg x . f) (Tr.popPos . f') -write :: (a -> String) -> C r -> C (a -> r)-write f = \k k' s x -> k (\s -> k' s x) (f x ++ s)+write :: (a -> String) -> Tr r (a -> r)+write f = Tr \k k' s x -> k (\s -> k' s x) (s ++ f x) -write0 :: String -> C r -> C r-write0 x = \k k' s -> write id k (\s _ -> k' s) s x+write0 :: String -> Tr r r+write0 x = Tr \k k' s -> unTr (write id) k (\s _ -> k' s) s x --- | Strip/add the given string from/to the output string.+-- | Strip\/add the given string from\/to the output string. string :: String -> PP0--- We could implement 'string' in terms of many, satisfy, char and unshift,--- but don't, purely to reduce unnecessary choice points during parsing.-string x = K7 (\k k' s -> maybe (k' s) (k k') $ stripPrefix x s) (write0 x)+-- We could implement 'string' in terms of many, satisfy, char and unshift, but+-- don't, purely to reduce unnecessary choice points during parsing.+string x = K7 (write0 x) (Tr \k k' s -> maybe (k' s) (k k') $ stripPrefix x s)  -- | Successful only if predicate holds. satisfy :: (Char -> Bool) -> PP Char-satisfy p = K7 f g where-  f k k' (x:xs) | p x = k (\s _ -> k' s) xs x-  f k k' s = k' s-  g k k' s x | p x = k (\s -> k' s x) (x:s)-             | otherwise = k' s x+satisfy p = K7 (Tr f) (Tr f')+  where+    f k k' s x+      | p x = k (\s -> k' s x) (s ++ [x])+      | otherwise = k' s x+    f' k k' (c:cs) u+      | p c = k (\cs _ -> k' cs u) cs (u c)+    f' _ k' s u = k' s u --- | Parse/print without consuming/producing any input.+-- | Parse\/print without consuming\/producing any input.+--+-- >>> let spec = lookAhead (satisfy (=='A')) . string "A"+-- >>> parse spec "ABCD"+-- Just 'A' lookAhead :: PP a -> PP a-lookAhead (K7 f f') = K7 (\k k' s -> f (\k' _ -> k k' s) k' s) (\k k' s -> f' (\k' _ -> k k' s) k' s)+lookAhead csst = K7 (Tr g) (Tr g')+  where+    g k k' s = unTr (sideA csst) (\k' _ -> k k' s) k' s+    g' k k' s = unTr (sideB csst) (\k' _ -> k k' s) k' s  -- | Succeeds if input string is empty.+--+-- >>> parse (set () eof) ""+-- Just ()+--+-- >>> parse (set () eof) "ABCD"+-- Nothing eof :: PP0-eof = K7 isEmpty isEmpty where-  isEmpty k k' "" = k k' ""-  isEmpty k k' s  = k' s+eof = K7 (Tr isEmpty) (Tr isEmpty)+  where+    isEmpty k k' "" = k k' ""+    isEmpty _ k' s  = k' s