diff --git a/Codec/Sexpr.hs b/Codec/Sexpr.hs --- a/Codec/Sexpr.hs +++ b/Codec/Sexpr.hs @@ -1,50 +1,123 @@ -module Codec.Sexpr (Sexpr, - atom, - hintedAtom, - list, +-- |A Sexpr is an S-expressionin the style of Rivest's Canonical +-- S-expressions. Atoms may be of any type, but String and +-- ByteString have special support. Rivest's implementation of +-- S-expressions is unusual in supporting MIME type hints for each +-- atom. See http://people.csail.mit.edu/rivest/Sexp.txt + +module Codec.Sexpr (-- * Basics + Sexpr, isAtom, isList, - hint, - defaultHint, + atom, + list, unAtom, unList, + -- * Hinted Atoms + hintedAtom, + hint, + defaultHint, + -- * Character predicates to support encoding isTokenChar,isInitialTokenChar,isQuoteableChar ) where +import Control.Applicative import Data.Char +import qualified Data.Foldable as F +import Data.Traversable -data Sexpr = Atom String - | HintedAtom String String - | List [Sexpr] +data Sexpr s = Atom s + | HintedAtom String s + | List [Sexpr s] -instance Eq Sexpr where +instance Eq s => Eq (Sexpr s) where (List a) == (List b) = and $ zipWith (==) a b a == b = unAtom a == unAtom b && hint a == hint b +-- |The 'Functor' instance maps over the underlying atomic contents of +-- the S-expression. It does not map only over the top-level list, +-- but over the fringe. +instance Functor Sexpr where + fmap f (Atom s) = Atom (f s) + fmap f (HintedAtom h s) = HintedAtom h (f s) + fmap f (List ss) = List $ map (fmap f) ss + +instance F.Foldable Sexpr where + foldMap f (Atom s) = f s + foldMap f (HintedAtom h s) = f s + foldMap f (List ss) = F.foldMap (F.foldMap f) ss + +instance Traversable Sexpr where + traverse f (Atom s) = Atom <$> f s + traverse f (HintedAtom h s) = HintedAtom h <$> f s + traverse f (List ss) = List <$> traverse (traverse f) ss + +-- |@fold f s@ applies f to each sub-S-expression of s, from each leaf +-- to the root. @f@ need not preserve the shape of @s@, in contrast +-- to the shape-preserving @Traversable@ instance. +fold :: (Sexpr t -> Sexpr t) -> Sexpr t -> Sexpr t +fold f z@(Atom s) = f z +fold f z@(HintedAtom h s) = f z +fold f (List ss) = f . List $ map (fold f) ss + +-- |Any atom whose hint is not specified is assumed to be +-- "text/plain; charset=iso-8859-1". This is that default value. +defaultHint :: String defaultHint = "text/plain; charset=iso-8859-1" +-- |Construct an atom. +atom :: a -> Sexpr a atom s = Atom s + +-- |Construct a list. +list :: [Sexpr a] -> Sexpr a list xs = List xs + +-- |Construct an atom with a MIME type hint. +-- @'hintedAtom' 'defaultHint' == 'atom'@ +hintedAtom :: String -> a -> Sexpr a hintedAtom h s | h == defaultHint = Atom s hintedAtom h s = HintedAtom h s +-- |A predicate for recognizing lists. +isList :: Sexpr a -> Bool isList (List _) = True isList _ = False +-- |A predicate for identifying atoms, whether or not they have +-- explicit hints. +isAtom :: Sexpr a -> Bool isAtom (List _) = False isAtom _ = True +-- |Extract the hint of an atom. Lists do not have hints, but all +-- atoms have hints. +hint :: Sexpr a -> Maybe String hint (Atom s) = Just defaultHint hint (HintedAtom h s) = Just h hint _ = Nothing +-- |Extract the content of an atom, discarding any MIME type hint. +unAtom :: Sexpr s -> s unAtom (Atom s) = s unAtom (HintedAtom h s) = s +-- |Extract the sub-S-expressions of a List. If all you intend to do +-- is traverse or map over that list, the Functor instance of +-- S-expressions may work just fine. +unList :: Sexpr s -> [Sexpr s] unList (List xs) = xs +-- |Tokens may begin with any alphabetic character or the characters +-- in @"-./_:*+="@ ; +isInitialTokenChar :: Char -> Bool isInitialTokenChar x = isAlpha x || x `elem` "-./_:*+=" +-- |Tokens may internally contain any of the characters legitimate to +-- begin tokens, or any numeral. +isTokenChar :: Char -> Bool isTokenChar x = isAlphaNum x || x `elem` "-./_:*+=" +-- |Only token characters and spaces don't need to be escaped when +-- shown in the "quoted" syntax. +isQuoteableChar :: Char -> Bool isQuoteableChar x = isTokenChar x || isSpace x diff --git a/Codec/Sexpr/Parser.hs b/Codec/Sexpr/Parser.hs --- a/Codec/Sexpr/Parser.hs +++ b/Codec/Sexpr/Parser.hs @@ -1,62 +1,100 @@ +-- |All present parsers work on Strings, one character at a time. The canonical encoding is clearly susceptible to efficient parsing as a Lazy ByteString. +-- +-- This package also includes the Read instance for Sexprs. +-- +-- From Rivest's documentation: +-- +-- > :: | +-- > :: ? ; +-- > :: | | | | +-- > ; +-- > :: "[" "]" ; +-- > :: ":" ; +-- > :: + ; +-- > -- decimal numbers should have no unnecessary leading zeros +-- > -- any string of bytes, of the indicated length +-- > :: + ; +-- > :: ? "|" ( | )* "|" ; +-- > :: "#" ( | )* "#" ; +-- > :: ? +-- > :: "\"" "\"" +-- > :: "(" ( | )* ")" ; +-- > :: * ; +-- > :: | | ; +-- > :: | | ; +-- > :: "a" | ... | "z" ; +-- > :: "A" | ... | "Z" ; +-- > :: "0" | ... | "9" ; +-- > :: | "A" | ... | "F" | "a" | ... | "f" ; +-- > :: "-" | "." | "/" | "_" | ":" | "*" | "+" | "=" ; +-- > :: " " | "\t" | "\r" | "\n" ; +-- > :: | | "+" | "/" | "=" ; +-- > :: "" ; + module Codec.Sexpr.Parser (readSexpr, + readSexprString, sexpr, canonicalSexpr) where import Codec.Sexpr +-- import Data.Binary.Get +-- import Data.ByteString + import Data.Char import Text.ParserCombinators.ReadP import qualified Codec.Binary.Base64.String as B64 -{- -From Rivest's documentation: - :: | - :: ? ; - :: | | | | - ; - :: "[" "]" ; - :: ":" ; - :: + ; - -- decimal numbers should have no unnecessary leading zeros - -- any string of bytes, of the indicated length - :: + ; - :: ? "|" ( | )* "|" ; - :: "#" ( | )* "#" ; - :: ? - :: "\"" "\"" - :: "(" ( | )* ")" ; - :: * ; - :: | | ; - :: | | ; - :: "a" | ... | "z" ; - :: "A" | ... | "Z" ; - :: "0" | ... | "9" ; - :: | "A" | ... | "F" | "a" | ... | "f" ; - :: "-" | "." | "/" | "_" | ":" | "*" | "+" | "=" ; - :: " " | "\t" | "\r" | "\n" ; - :: | | "+" | "/" | "=" ; - :: "" ; --} +instance Read s => Read (Sexpr s) where + readsPrec n s = map (\(a,b) -> (fmap read a, b)) s' + where + s' = readP_to_S sexpr s :: [(Sexpr String,String)] -instance Read Sexpr where - readsPrec n = readP_to_S sexpr +-- |Read a @'Sexpr' 'String'@ in any encoding: Canonical, Basic, or Advanced. +readSexprString :: String -> Sexpr String +readSexprString s = fst . head $ readP_to_S sexpr s -readSexpr s = fst . head $ readP_to_S sexpr s +-- |Read a @'Sexpr' a@ using the 'Read' instance for @a@. The Sexpr +-- may be in any encoding: Canonical, Basic, or Advanced. +readSexpr :: Read a => String -> Sexpr a +readSexpr = fmap read . readSexprString +-- |Parser for @'Sexpr' 'String'@s suitable for embedding in other +-- @ReadP@ parsers. +sexpr :: ReadP (Sexpr String) sexpr = do skipSpaces s <- canonicalSexpr skipSpaces return s -canonicalSexpr :: ReadP Sexpr +{- +getCanonicalAtom :: Get (Sexpr ByteString) +getCanonicalAtom = do + l <- getDecimal + skip 1 -- ':' + s <- getLazyByteString l -- FIXME doesn't handle hints + return $ atom s + +getCanonicalList :: Get S +getCanonicalList = do + skip 1 -- '(' + -- FIXME mostly missing +-} + +-- |For some applications it is wise to accept only very carefully +-- specified input. This is useful when you know you are receiving +-- exactly a Canonical S-Expression. It will read only a Canonical +-- S-expression (and optional terminating NUL), but not the Basic or +-- Advanced encodings. +canonicalSexpr :: ReadP (Sexpr String) canonicalSexpr = do s <- atomR <++ listR <++ basicTransport optional $ char '\NUL' return s -basicTransport :: ReadP Sexpr +basicTransport :: ReadP (Sexpr String) basicTransport = do b64Octets <- between (char '{') (char '}') $ many1 b64char let parses = readP_to_S sexpr $ B64.decode b64Octets @@ -68,12 +106,12 @@ hexchar = satisfy isHexDigit hexchar' = skipSpaces >> hexchar -listR :: ReadP Sexpr +listR :: ReadP (Sexpr String) listR = do l <- between (char '(') (char ')') $ many sexpr return $ list l -atomR :: ReadP Sexpr +atomR :: ReadP (Sexpr String) atomR = unhinted +++ hinted where unhinted = simpleString >>= (return . atom) diff --git a/Codec/Sexpr/Printer.hs b/Codec/Sexpr/Printer.hs --- a/Codec/Sexpr/Printer.hs +++ b/Codec/Sexpr/Printer.hs @@ -1,23 +1,55 @@ -module Codec.Sexpr.Printer (canonical, canonicalString, - basic, basicString, - advanced, advancedString +{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} + +-- | Export S-expressions in any of the three ordinary forms: +-- +-- * Canonical, where a different string implies a different meaning +-- +-- * Basic, suitable for transport over 7-bit and awkward media +-- +-- * Advanced, a human-readable pretty-printed encoding. +-- +-- The @-> 'String'@ functions are probably what you want unless you +-- know you want something else. +-- +-- The 'Show' instance for Sexpr is provided here, using +-- advancedString and the underlying Show instance. Overlapping +-- instances are used to provide a nice show for @'Sexpr' 'String'@. + +module Codec.Sexpr.Printer (-- * String printers + canonicalString, + basicString, + advancedString, + -- * ShowS printers + canonical, + -- * Doc pretty printers + basic, + advanced, + -- * Put binary printers + putCanonical, putCanonicalBS ) where import Codec.Sexpr +import Data.Binary.Put +import qualified Data.ByteString.Char8 as B + import Data.Char import Data.Maybe import Text.PrettyPrint import qualified Codec.Binary.Base64.String as B64 -instance Show Sexpr where +instance Show (Sexpr String) where show s = advancedString s +instance Show s => Show (Sexpr s) where + show s = advancedString $ fmap show s + raw s = shows (length s) . showString ":" . showString s +canonicalString :: Sexpr String -> String canonicalString s = canonical s "" -canonical :: Sexpr -> ShowS +canonical :: Sexpr String -> ShowS canonical s | isAtom s && hint s == Just defaultHint = raw $ unAtom s canonical s | isAtom s = showString "[" . raw (fromJust $ hint s) @@ -27,13 +59,48 @@ . showString (foldr (.) id (map canonical $ unList s) $ "") . showString ")" +putRaw :: String -> Put +putRaw s = do + putByteString . B.pack . show $ length s + putChar' ':' + putByteString (B.pack s) + +putRawBS :: B.ByteString -> Put +putRawBS s = do + putByteString . B.pack . show $ B.length s + putChar' ':' + putByteString s + +putChar' = putWord8 . fromIntegral . ord + +putCanonical :: Sexpr String -> Put +putCanonical = putCanonicalHelper putRaw + +putCanonicalBS :: Sexpr B.ByteString -> Put +putCanonicalBS = putCanonicalHelper putRawBS + +putCanonicalHelper :: (a -> Put) -> Sexpr a -> Put +putCanonicalHelper putRaw' s | isAtom s && hint s == + Just defaultHint = putRaw' $ unAtom s +putCanonicalHelper putRaw' s | isAtom s = do + putChar' '[' + putRaw (fromJust $ hint s) + putChar' ']' + putRaw' (unAtom s) +putCanonicalHelper putRaw' s | isList s = do + putChar' '(' + mapM_ (putCanonicalHelper putRaw') $ unList s + putChar' ')' + +basicString :: Sexpr String -> String basicString s = render $ basic s -basic :: Sexpr -> Doc +basic :: Sexpr String -> Doc basic s = braces . hcat $ map char . B64.encode $ canonical s "" -- FIXME should basic add and encode a NUL terminator? --- FIXMIE We parse it out in canonical---should canonical encodings end with a NUL? +-- FIXME We parse it out in canonical---should canonical encodings end with a NUL? +advancedString :: Sexpr String -> String advancedString s = render $ advanced s @@ -59,6 +126,7 @@ base64 s = (char '|') <> hcat (map char $ B64.encode s) <> (char '|') +advanced :: Sexpr String -> Doc advanced s | isAtom s && hint s == Just defaultHint = format $ unAtom s advanced s | isAtom s = brackets (format $ fromJust $ hint s) <> (format $ unAtom s) diff --git a/sexpr.cabal b/sexpr.cabal --- a/sexpr.cabal +++ b/sexpr.cabal @@ -1,5 +1,5 @@ Name: sexpr -Version: 0.1.1 +Version: 0.1.2 Cabal-Version: >= 1.2 Synopsis: S-expression printer and parser Description: Parser and printer for S-expressions, including Ron @@ -14,6 +14,6 @@ Build-type: Simple Library - Build-Depends: base, base64-string, pretty + Build-Depends: base, base64-string, pretty, bytestring, binary Exposed-modules: Codec.Sexpr, Codec.Sexpr.Parser, Codec.Sexpr.Printer