cassette (empty) → 0.1.0

raw patch · 9 files changed

+508/−0 lines, 9 filesdep +basesetup-changed

Dependencies added: base

Files

• LICENSE +27/−0
• Setup.lhs +3/−0
• cassette.cabal +28/−0
• src/Text/Cassette.hs +62/−0
• src/Text/Cassette/Char.hs +67/−0
• src/Text/Cassette/Combinator.hs +89/−0
• src/Text/Cassette/Lead.hs +80/−0
• src/Text/Cassette/Number.hs +14/−0
• src/Text/Cassette/Prim.hs +138/−0

@@ -0,0 +1,27 @@+Copyright (c) 2012 Mathieu Boespflug++All rights reserved.++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.++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.

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

@@ -0,0 +1,28 @@+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++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

@@ -0,0 +1,62 @@+-- | 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.+--+-- Here is an example specification for the lambda-calculus:+--+-- > 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)+--+-- From this single specification, we can extract a parser,+--+-- > parse term :: PP Term -> String -> Maybe Term+--+-- and also a pretty printer,+--+-- > pretty term :: PP Term -> Term -> Maybe String+--+-- 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".+--+-- 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.++module Text.Cassette+       ( module Text.Cassette.Prim+       , module Text.Cassette.Lead+       , module Text.Cassette.Combinator+       , module Text.Cassette.Char+       , module Text.Cassette.Number ) where++import Text.Cassette.Prim+import Text.Cassette.Lead+import Text.Cassette.Combinator+import Text.Cassette.Char+import Text.Cassette.Number

@@ -0,0 +1,67 @@+module Text.Cassette.Char where++import Text.Cassette.Prim+import Text.Cassette.Combinator+import Data.Char+++-- | Succeeds if the current character is in the supplied list of characters.+-- See also 'satisfy'.+--+-- > vowel = oneOf "aeiou"+oneOf :: [Char] -> PP Char+oneOf xs = satisfy (`elem` xs)++-- | Dual of 'oneOf'.+noneOf :: [Char] -> PP Char+noneOf xs = satisfy (not . (`elem` xs))++-- | The 'satisfy' combinator, unshifted.+skip :: (Char -> Bool) -> Char -> PP0+skip p x = unshift 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 :: PP0+skipSpace = unshift "" $ 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 :: PP0+optSpace = unshift " " $ 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 :: PP0+sepSpace = string " " <> skipSpace++-- | Parses a newline character (\'\\n\').+newline :: PP0+newline = char '\n'++-- | Parses a tab character (\'\\t\').+tab :: PP0+tab = char '\t'++upper, lower, alphaNum, letter, digit, hexDigit, octDigit, anyChar :: PP Char++upper = satisfy isUpper+lower = satisfy isLower+alphaNum = satisfy isAlphaNum+letter = satisfy isAlpha+digit = satisfy isDigit+hexDigit = satisfy isHexDigit+octDigit = satisfy isOctDigit++-- | Any character.+anyChar = satisfy (const True)++-- | A specific character.+char :: Char -> PP0+char x = string [x]

@@ -0,0 +1,89 @@+{-# LANGUAGE RankNTypes, ImpredicativeTypes #-}+module Text.Cassette.Combinator where++import Text.Cassette.Prim+import Text.Cassette.Lead+++-- | 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++-- | @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++-- | 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++-- | 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++-- | 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)++-- | Apply the given cassette zero or more times.+many :: PP a -> PP [a]+many p = many1 p <|> nilL++-- | Apply the given cassette one or more times.+many1 :: PP a -> PP [a]+many1 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++-- | Apply the given cassette one or more times, discarding the result.+skipMany1 :: PP a -> PP0+skipMany1 p = unshift [] $ many1 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++-- | 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)++-- | @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++-- | Match a 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)++-- | @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++-- | Match a 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)++-- | @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++-- | 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

@@ -0,0 +1,80 @@+{-# LANGUAGE RankNTypes #-}+module Text.Cassette.Lead where++import Text.Cassette.Prim+++-- | 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'))++-- | 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'))++-- | 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))++-- | 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++-- | 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++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)++nilL :: PP [a]+nilL = shift [] nothing++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)++nothingL :: PP (Maybe a)+nothingL = shift Nothing 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)++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)++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)

@@ -0,0 +1,14 @@+-- | This module exports combinators for parsing number literals.+module Text.Cassette.Number where++import Text.Cassette.Prim+import Text.Cassette.Lead+import Text.Cassette.Combinator+import Text.Cassette.Char+++-- | 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

@@ -0,0 +1,138 @@+{-# LANGUAGE RankNTypes #-}+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++import Data.List (stripPrefix)+import Control.Category+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 }++infixr 9 <>++-- | 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 Category Sym where+  id = Sym (K7 id id)+  Sym csst1 . Sym csst2 = Sym (csst1 <> csst2)++infixr 8 -->++-- | A synonym to '(<>)' with its arguments flipped and with lower precedence.+(-->) = Prelude.flip (<>)++-- | The type of string transformers in CPS, /i.e./ functions from strings to+-- strings.+type C r = (String -> r) -> String -> r++-- | 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++-- | 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++-- | Extract the parser from a cassette.+parse :: PP a -> String -> Maybe a+parse csst = play csst (\_ _ x -> Just x) (const Nothing)++-- | 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 <|>++-- | 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)++-- | Always fail.+empty :: PP0+empty = K7 (\k k' s -> k' s) (\k k' s -> k' s)++-- | Do nothing.+nothing :: PP0+nothing = K7 id 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+-- 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+-- 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)++-- | 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)++write :: (a -> String) -> C r -> C (a -> r)+write f = \k k' s x -> k (\s -> k' s x) (f x ++ s)++write0 :: String -> C r -> C r+write0 x = \k k' s -> write id k (\s _ -> k' s) s x++-- | 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)++-- | 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++-- | Parse/print without consuming/producing any input.+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)++-- | Succeeds if input string is empty.+eof :: PP0+eof = K7 isEmpty isEmpty where+  isEmpty k k' "" = k k' ""+  isEmpty k k' s  = k' s