diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/cassette.cabal b/cassette.cabal --- a/cassette.cabal +++ b/cassette.cabal @@ -1,28 +1,38 @@ -Name: cassette -Version: 0.1.0 -Author: Mathieu Boespflug -Maintainer: Mathieu Boespflug -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 +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 diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens.hs @@ -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 diff --git a/src/Text/Cassette.hs b/src/Text/Cassette.hs --- a/src/Text/Cassette.hs +++ b/src/Text/Cassette.hs @@ -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 diff --git a/src/Text/Cassette/Char.hs b/src/Text/Cassette/Char.hs --- a/src/Text/Cassette/Char.hs +++ b/src/Text/Cassette/Char.hs @@ -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. diff --git a/src/Text/Cassette/Combinator.hs b/src/Text/Cassette/Combinator.hs --- a/src/Text/Cassette/Combinator.hs +++ b/src/Text/Cassette/Combinator.hs @@ -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 diff --git a/src/Text/Cassette/Internal/Tr.hs b/src/Text/Cassette/Internal/Tr.hs new file mode 100644 --- /dev/null +++ b/src/Text/Cassette/Internal/Tr.hs @@ -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) diff --git a/src/Text/Cassette/Lead.hs b/src/Text/Cassette/Lead.hs --- a/src/Text/Cassette/Lead.hs +++ b/src/Text/Cassette/Lead.hs @@ -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)) diff --git a/src/Text/Cassette/Number.hs b/src/Text/Cassette/Number.hs --- a/src/Text/Cassette/Number.hs +++ b/src/Text/Cassette/Number.hs @@ -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) diff --git a/src/Text/Cassette/Prim.hs b/src/Text/Cassette/Prim.hs --- a/src/Text/Cassette/Prim.hs +++ b/src/Text/Cassette/Prim.hs @@ -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