s-cargot (empty) → 0.1.0.0
raw patch · 14 files changed
+2127/−0 lines, 14 filesdep +basedep +containersdep +parsecsetup-changed
Dependencies added: base, containers, parsec, text
Files
- Data/SCargot.hs +94/−0
- Data/SCargot/Comments.hs +172/−0
- Data/SCargot/Common.hs +218/−0
- Data/SCargot/Language/Basic.hs +54/−0
- Data/SCargot/Language/HaskLike.hs +158/−0
- Data/SCargot/Parse.hs +261/−0
- Data/SCargot/Print.hs +219/−0
- Data/SCargot/Repr.hs +183/−0
- Data/SCargot/Repr/Basic.hs +225/−0
- Data/SCargot/Repr/Rich.hs +260/−0
- Data/SCargot/Repr/WellFormed.hs +207/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- s-cargot.cabal +44/−0
+ Data/SCargot.hs view
@@ -0,0 +1,94 @@+module Data.SCargot+ ( -- * SCargot Basics++ -- $intro++ -- * Parsing and Printing+ decode+ , decodeOne+ , encode+ , encodeOne+ -- * Parser Construction+ -- ** Specifying a Parser+ , SExprParser+ , Reader+ , Comment+ , mkParser+ , setCarrier+ , addReader+ , setComment+ , asRich+ , asWellFormed+ , withQuote+ -- * Printer Construction+ -- * Specifying a Pretty-Printer+ , SExprPrinter+ , Indent(..)+ , basicPrint+ , flatPrint+ , setFromCarrier+ , setMaxWidth+ , removeMaxWidth+ , setIndentAmount+ , setIndentStrategy+ ) where++import Data.SCargot.Parse+import Data.SCargot.Print++{- $intro++The S-Cargot library is a library for parsing and emitting+<https://en.wikipedia.org/wiki/S-expression s-expressions>, designed+to be as flexible as possible. Despite some efforts at+<http://people.csail.mit.edu/rivest/Sexp.txt standardization>,+s-expressions are a general approach to describing a data format+that can very often differ in subtle, incompatible ways: the+s-expressions understood by Common Lisp are different from the+s-expressions understood by Scheme, and even the different+revisions of the Scheme language understand s-expressions in a+slightly different way. To accomodate this, the S-Cargot library+provides a toolbox for defining variations on s-expressions,+complete with the ability to select various comment syntaxes, reader+macros, and atom types.++If all you want is to read some s-expressions and don't care about+the edge cases of the format, or all you want is a new configuration+format, try the "Data.SCargot.Language.Basic" or "Data.SCargot.Language.HaskLike"+modules, which define an s-expression language whose atoms are+plain strings and Haskell literals, respectively.++The S-Cargot library works by specifying values which contain all+the information needed to either parse or print an s-expression.+The actual s-expression structure is parsed as a structure of+<https://en.wikipedia.org/wiki/Cons cons cells> as represented+by the 'SExpr' type, but can alternately be exposed as the+isomorphic 'RichSExpr' type or the less expressive but+easier-to-work-with 'WellFormedSExpr' type. Modules devoted+to each representation type (in "Data.SCargot.Repr.Basic",+"Data.SCargot.Repr.Rich", and "Data.SCargot.Repr.WellFormed")+provide helper functions, lenses, and pattern synonyms to make+creating and processing these values easier.++The details of how to parse a given structure are represented+by building up a 'SExprParser' value, which is defined in+"Data.SCargot.Parse" and re-exported here. A minimal+'SExprParser' defines only how to parse the atoms of the+language; helper functions can define comment syntaxes,+reader macros, and transformations over the parsed structure.++The details of how to print a given structure are represented+by building up a 'SExprPrinter' value, which is defined in+"Data.SCargot.Print" and re-exported here. A minimal+'SExprPrinter' defines only how to print the atoms of the+language; helper functions help with the layout of the+pretty-printed s-expression in terms of how to indent the+surrounding expression.++Other helper modules define useful primitives for building up+s-expression languages: the "Data.SCargot.Common" module provides+parsers for common literals, while the "Data.SCargot.Comments"+module provides parsers for comment syntaxes borrowed from+various other languages.++-}
+ Data/SCargot/Comments.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.SCargot.Comments+ ( -- $intro++ -- * Lisp-Style Syntax++ -- $lisp+ withLispComments+ -- * Other Existing Comment Syntaxes+ -- ** Scripting Language Syntax+ -- $script+ , withOctothorpeComments+ -- ** C-Style Syntax+ -- $clike+ , withCLikeLineComments+ , withCLikeBlockComments+ , withCLikeComments+ -- ** Haskell-Style Syntax+ -- $haskell+ , withHaskellLineComments+ , withHaskellBlockComments+ , withHaskellComments+ -- * Comment Syntax Helper Functions+ , lineComment+ , simpleBlockComment+ ) where++import Text.Parsec ( (<|>)+ , anyChar+ , manyTill+ , noneOf+ , skipMany+ , string+ )++import Data.SCargot.Parse ( Comment+ , SExprParser+ , setComment+ )++-- | Given a string, produce a comment parser that matches that+-- initial string and ignores everything until the end of the+-- line.+lineComment :: String -> Comment+lineComment s = string s >> skipMany (noneOf "\n") >> return ()++-- | Given two strings, a begin and an end delimeter, produce a+-- parser that matches the beginning delimeter and then ignores+-- everything until it finds the end delimiter. This does not+-- consider nesting, so, for example, a comment created with+--+-- > curlyComment :: Comment+-- > curlyComment = simpleBlockComment "{" "}"+--+-- will consider+--+-- > { this { comment }+--+-- to be a complete comment, despite the apparent improper nesting.+-- This is analogous to standard C-style comments in which+--+-- > /* this /* comment */+--+-- is a complete comment.+simpleBlockComment :: String -> String -> Comment+simpleBlockComment begin end =+ string begin >>+ manyTill anyChar (string end) >>+ return ()++-- | Lisp-style line-oriented comments start with @;@ and last+-- until the end of the line. This is usually the comment+-- syntax you want.+withLispComments :: SExprParser t a -> SExprParser t a+withLispComments = setComment (lineComment ";")++-- | C++-like line-oriented comment start with @//@ and last+-- until the end of the line.+withCLikeLineComments :: SExprParser t a -> SExprParser t a+withCLikeLineComments = setComment (lineComment "//")++-- | C-like block comments start with @/*@ and end with @*/@.+-- They do not nest.+withCLikeBlockComments :: SExprParser t a -> SExprParser t a+withCLikeBlockComments = setComment (simpleBlockComment "/*" "*/")++-- | C-like comments include both line- and block-comments, the+-- former starting with @//@ and the latter contained within+-- @//* ... *//@.+withCLikeComments :: SExprParser t a -> SExprParser t a+withCLikeComments = setComment (lineComment "//" <|>+ simpleBlockComment "/*" "*/")++-- | Haskell line-oriented comments start with @--@ and last+-- until the end of the line.+withHaskellLineComments :: SExprParser t a -> SExprParser t a+withHaskellLineComments = setComment (lineComment "--")++-- | Haskell block comments start with @{-@ and end with @-}@.+-- They do not nest.+withHaskellBlockComments :: SExprParser t a -> SExprParser t a+withHaskellBlockComments = setComment (simpleBlockComment "{-" "-}")++-- | Haskell comments include both the line-oriented @--@ comments+-- and the block-oriented @{- ... -}@ comments+withHaskellComments :: SExprParser t a -> SExprParser t a+withHaskellComments = setComment (lineComment "--" <|>+ simpleBlockComment "{-" "-}")++-- | Many scripting and shell languages use these, which begin with+-- @#@ and last until the end of the line.+withOctothorpeComments :: SExprParser t a -> SExprParser t a+withOctothorpeComments = setComment (lineComment "#")+++{- $intro++By default a 'SExprParser' will not understand any kind of comment+syntax. Most varieties of s-expression will, however, want some kind+of commenting capability, so the below functions will produce a new+'SExprParser' which understands various kinds of comment syntaxes.++For example:++> mySpec :: SExprParser Text (SExpr Text)+> mySpec = asWellFormed $ mkParser (pack <$> many1 alphaNum)+>+> myLispySpec :: SExprParser Text (SExpr Text)+> myLispySpec = withLispComments mySpec+>+> myCLikeSpec :: SExprParser Text (SExpr Text)+> myCLikeSpec = withCLikeComment mySpec++We can then use these to parse s-expressions with different kinds of+comment syntaxes:++>>> decode mySpec "(foo ; a lisp comment\n bar)\n"+Left "(line 1, column 6):\nunexpected \";\"\nexpecting space or atom"+>>> decode myLispySpec "(foo ; a lisp comment\n bar)\n"+Right [WFSList [WFSAtom "foo", WFSAtom "bar"]]+>>> decode mySpec "(foo /* a c-like\n comment */ bar)\n"+Left "(line 1, column 6):\nunexpected \"/\"\nexpecting space or atom"+>>> decode myCLikeSpec "(foo /* a c-like\n comment */ bar)\n"+Right [WFSList [WFSAtom "foo", WFSAtom "bar"]]++-}++{- $lisp+> (one ; a comment+> two ; another one+> three)+-}++{- $script+> (one # a comment+> two # another one+> three)+-}++{- $clike+> (one // a comment+> two /* another+> one */+> three)+-}++-- $haskell+-- > (one -- a comment+-- > two {- another+-- > one -}+-- > three)
+ Data/SCargot/Common.hs view
@@ -0,0 +1,218 @@+module Data.SCargot.Common ( -- $intro+ -- * Lisp Identifier Syntaxes+ parseR5RSIdent+ , parseR6RSIdent+ , parseR7RSIdent+ -- * Numeric Literal Parsers+ , signed+ , prefixedNumber+ , signedPrefixedNumber+ , binNumber+ , signedBinNumber+ , octNumber+ , signedOctNumber+ , decNumber+ , signedDecNumber+ , dozNumber+ , signedDozNumber+ , hexNumber+ , signedHexNumber+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative hiding ((<|>), many)+#endif+import Data.Char+import Data.Text (Text)+import qualified Data.Text as T+import Text.Parsec+import Text.Parsec.Text (Parser)++-- | Parse an identifier according to the R5RS Scheme standard. This+-- will not normalize case, even though the R5RS standard specifies+-- that all identifiers be normalized to lower case first.+--+-- An R5RS identifier is, broadly speaking, alphabetic or numeric+-- and may include various symbols, but no escapes.+parseR5RSIdent :: Parser Text+parseR5RSIdent =+ T.pack <$> ((:) <$> initial <*> many subsequent <|> peculiar)+ where initial = letter <|> oneOf "!$%&*/:<=>?^_~"+ subsequent = initial <|> digit <|> oneOf "+-.@"+ peculiar = string "+" <|> string "-" <|> string "..."++hasCategory :: Char -> [GeneralCategory] -> Bool+hasCategory c cs = generalCategory c `elem` cs++-- | Parse an identifier according to the R6RS Scheme standard. An+-- R6RS identifier may include inline hexadecimal escape sequences+-- so that, for example, @foo@ is equivalent to @f\\x6f;o@, and is+-- more liberal than R5RS as to which Unicode characters it may+-- accept.+parseR6RSIdent :: Parser Text+parseR6RSIdent =+ T.pack <$> ((:) <$> initial <*> many subsequent <|> peculiar)+ where initial = constituent <|> oneOf "!$%&*/:<=>?^_~" <|> inlineHex+ constituent = letter+ <|> uniClass (\ c -> isLetter c ||+ isSymbol c ||+ hasCategory c+ [ NonSpacingMark+ , LetterNumber+ , OtherNumber+ , DashPunctuation+ , ConnectorPunctuation+ , OtherPunctuation+ , PrivateUse+ ])+ inlineHex = (chr . fromIntegral) <$> (string "\\x" *> hexNumber <* char ';')+ subsequent = initial <|> digit <|> oneOf "+-.@"+ <|> uniClass (\ c -> hasCategory c+ [ DecimalNumber+ , SpacingCombiningMark+ , EnclosingMark+ ])+ peculiar = string "+" <|> string "-" <|> string "..." <|>+ ((++) <$> string "->" <*> many subsequent)+ uniClass :: (Char -> Bool) -> Parser Char+ uniClass sp = satisfy (\ c -> c > '\x7f' && sp c)++-- | Parse an identifier according to the R7RS Scheme standard. An+-- R7RS identifier, in addition to a typical identifier format,+-- can also be a chunk of text surrounded by vertical bars that+-- can contain spaces and other characters. Unlike R6RS, it does+-- not allow escapes to be included in identifiers unless those+-- identifiers are surrounded by vertical bars.+parseR7RSIdent :: Parser Text+parseR7RSIdent = T.pack <$>+ ( (:) <$> initial <*> many subsequent+ <|> char '|' *> many1 symbolElement <* char '|'+ <|> peculiar+ )+ where initial = letter <|> specInit+ specInit = oneOf "!$%&*/:<=>?^_~"+ subsequent = initial <|> digit <|> specSubsequent+ specSubsequent = expSign <|> oneOf ".@"+ expSign = oneOf "+-"+ symbolElement = noneOf "\\|"+ <|> hexEscape+ <|> mnemEscape+ <|> ('|' <$ string "\\|")+ hexEscape = chr . fromIntegral <$> (string "\\x" *> hexNumber <* char ';')+ mnemEscape = '\a' <$ string "\\a"+ <|> '\b' <$ string "\\b"+ <|> '\t' <$ string "\\t"+ <|> '\n' <$ string "\\n"+ <|> '\r' <$ string "\\r"+ peculiar = (:[]) <$> expSign+ <|> cons2 <$> expSign <*> signSub <*> many subsequent+ <|> cons3 <$> expSign+ <*> char '.'+ <*> dotSub+ <*> many subsequent+ <|> cons2 <$> char '.' <*> dotSub <*> many subsequent+ dotSub = signSub <|> char '.'+ signSub = initial <|> expSign <|> char '@'+ cons2 a b cs = a : b : cs+ cons3 a b c ds = a : b : c : ds++-- | A helper function for defining parsers for arbitrary-base integers.+-- The first argument will be the base, and the second will be the+-- parser for the individual digits.+number :: Integer -> Parser Char -> Parser Integer+number base digits = foldl go 0 <$> many1 digits+ where go x d = base * x + toInteger (value d)+ value c+ | c == 'a' || c == 'A' = 0xa+ | c == 'b' || c == 'B' = 0xb+ | c == 'c' || c == 'C' = 0xc+ | c == 'd' || c == 'D' = 0xd+ | c == 'e' || c == 'E' = 0xe+ | c == 'f' || c == 'F' = 0xf+ | c >= '0' && c <= '9' = fromEnum c - fromEnum '0'+ | c == '\x218a' = 0xa+ | c == '\x218b' = 0xb+ | otherwise = error ("Unknown letter in number: " ++ show c)++sign :: Num a => Parser (a -> a)+sign = (pure id <* char '+')+ <|> (pure negate <* char '-')+ <|> pure id++-- | Given a parser for some kind of numeric literal, this will attempt to+-- parse a leading @+@ or a leading @-@ followed by the numeric literal,+-- and if a @-@ is found, negate that literal.+signed :: Num a => Parser a -> Parser a+signed p = ($) <$> sign <*> p++-- | Parses a number in the same way as 'prefixedNumber', with an optional+-- leading @+@ or @-@.+signedPrefixedNumber :: Parser Integer+signedPrefixedNumber = signed prefixedNumber++-- | Parses a number, determining which numeric base to use by examining+-- the literal's prefix: @0x@ for a hexadecimal number, @0z@ for a+-- dozenal number, @0o@ for an octal number, and @0b@ for a binary+-- number (as well as the upper-case versions of the same.) If the+-- base is omitted entirely, then it is treated as a decimal number.+prefixedNumber :: Parser Integer+prefixedNumber = (string "0x" <|> string "0X") *> hexNumber+ <|> (string "0o" <|> string "0O") *> octNumber+ <|> (string "0z" <|> string "0Z") *> dozNumber+ <|> (string "0b" <|> string "0B") *> binNumber+ <|> decNumber++-- | A parser for non-signed binary numbers+binNumber :: Parser Integer+binNumber = number 2 (char '0' <|> char '1')++-- | A parser for signed binary numbers, with an optional leading @+@ or @-@.+signedBinNumber :: Parser Integer+signedBinNumber = signed binNumber++-- | A parser for non-signed octal numbers+octNumber :: Parser Integer+octNumber = number 8 (oneOf "01234567")++-- | A parser for signed octal numbers, with an optional leading @+@ or @-@.+signedOctNumber :: Parser Integer+signedOctNumber = ($) <$> sign <*> octNumber++-- | A parser for non-signed decimal numbers+decNumber :: Parser Integer+decNumber = number 10 digit++-- | A parser for signed decimal numbers, with an optional leading @+@ or @-@.+signedDecNumber :: Parser Integer+signedDecNumber = ($) <$> sign <*> decNumber++dozDigit :: Parser Char+dozDigit = digit <|> oneOf "AaBb\x218a\x218b"++-- | A parser for non-signed duodecimal (dozenal) numbers. This understands both+-- the ASCII characters @'a'@ and @'b'@ and the Unicode characters @'\x218a'@ (↊)+-- and @'\x218b'@ (↋) as digits with the decimal values @10@ and @11@+-- respectively.+dozNumber :: Parser Integer+dozNumber = number 12 dozDigit++-- | A parser for signed duodecimal (dozenal) numbers, with an optional leading @+@ or @-@.+signedDozNumber :: Parser Integer+signedDozNumber = ($) <$> sign <*> dozNumber++-- | A parser for non-signed hexadecimal numbers+hexNumber :: Parser Integer+hexNumber = number 16 hexDigit++-- | A parser for signed hexadecimal numbers, with an optional leading @+@ or @-@.+signedHexNumber :: Parser Integer+signedHexNumber = ($) <$> sign <*> hexNumber++{- $intro++This module contains a selection of parsers for different kinds of+identifiers and literals, from which more elaborate parsers can be+assembled. These can afford the user a quick way of building parsers+for different atom types.++-}
+ Data/SCargot/Language/Basic.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.SCargot.Language.Basic+ ( -- * Spec+ -- $descr+ basicParser+ , basicPrinter+ ) where++import Control.Applicative ((<$>))+import Data.Char (isAlphaNum)+import Text.Parsec (many1, satisfy)+import Data.Text (Text, pack)++import Data.SCargot.Repr.Basic (SExpr)+import Data.SCargot ( SExprParser+ , SExprPrinter+ , mkParser+ , flatPrint+ )++isAtomChar :: Char -> Bool+isAtomChar c = isAlphaNum c+ || c == '-' || c == '*' || c == '/'+ || c == '+' || c == '<' || c == '>'+ || c == '=' || c == '!' || c == '?'++-- $descr+-- The 'basicSpec' describes S-expressions whose atoms are simply+-- text strings that contain alphanumeric characters and a small+-- set of punctuation. It does no parsing of numbers or other data+-- types, and will accept tokens that typical Lisp implementations+-- would find nonsensical (like @77foo@).+--+-- Atoms recognized by the 'basicSpec' are any string matching the+-- regular expression @[A-Za-z0-9+*<>/=!?-]+@.++-- | A 'SExprParser' that understands atoms to be sequences of+-- alphanumeric characters as well as the punctuation+-- characters @[-*/+<>=!?]@, and does no processing of them.+--+-- >>> decode basicParser "(1 elephant)"+-- Right [SCons (SAtom "1") (SCons (SAtom "elephant") SNil)]+basicParser :: SExprParser Text (SExpr Text)+basicParser = mkParser pToken+ where pToken = pack <$> many1 (satisfy isAtomChar)++-- | A 'SExprPrinter' that prints textual atoms directly (without quoting+-- or any other processing) onto a single line.+--+-- >>> encode basicPrinter [L [A "1", A "elephant"]]+-- "(1 elephant)"+basicPrinter :: SExprPrinter Text (SExpr Text)+basicPrinter = flatPrint id
+ Data/SCargot/Language/HaskLike.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.SCargot.Language.HaskLike+ ( -- $info+ HaskLikeAtom(..)+ , haskLikeParser+ , haskLikePrinter+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<$))+#endif+import Data.Maybe (catMaybes)+import Data.String (IsString(..))+import Data.Text (Text, pack)+import Text.Parsec+import Text.Parsec.Text (Parser)++import Prelude hiding (concatMap)++import Data.SCargot.Common+import Data.SCargot.Repr.Basic (SExpr)+import Data.SCargot (SExprParser, SExprPrinter, mkParser, flatPrint)++{- $info++This module is intended for simple, ad-hoc configuration or data formats+that might not need their on rich structure but might benefit from a few+various kinds of literals. The 'haskLikeParser' understands identifiers as+defined by R5RS, as well as string, integer, and floating-point literals+as defined by the Haskell spec. It does __not__ natively understand other+data types, such as booleans, vectors, bitstrings.++-}+++-- | An atom type that understands Haskell-like values as well as+-- Scheme-like identifiers.+data HaskLikeAtom+ = HSIdent Text -- ^ An identifier, parsed according to the R5RS Scheme+ -- standard+ | HSString Text -- ^ A string, parsed according to the syntax for string+ -- literals in the Haskell report+ | HSInt Integer -- ^ An arbitrary-sized integer value, parsed according to+ -- the syntax for integer literals in the Haskell report+ | HSFloat Double -- ^ A double-precision floating-point value, parsed+ -- according to the syntax for floats in the Haskell+ -- report+ deriving (Eq, Show)++instance IsString HaskLikeAtom where+ fromString = HSIdent . fromString++pString :: Parser Text+pString = pack . catMaybes <$> between (char '"') (char '"') (many (val <|> esc))+ where val = Just <$> satisfy (\ c -> c /= '"' && c /= '\\' && c > '\026')+ esc = do _ <- char '\\'+ Nothing <$ (gap <|> char '&') <|>+ Just <$> code+ gap = many1 space >> char '\\'+ code = eEsc <|> eNum <|> eCtrl <|> eAscii+ eCtrl = char '^' >> unCtrl <$> upper+ eNum = (toEnum . fromInteger) <$>+ (decNumber <|> (char 'o' >> octNumber)+ <|> (char 'x' >> hexNumber))+ eEsc = choice [ char a >> return b | (a, b) <- escMap ]+ eAscii = choice [ try (string a >> return b)+ | (a, b) <- asciiMap ]+ unCtrl c = toEnum (fromEnum c - fromEnum 'A' + 1)++escMap :: [(Char, Char)]+escMap = zip "abfntv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"++asciiMap :: [(String, Char)]+asciiMap = zip+ ["BS","HT","LF","VT","FF","CR","SO","SI","EM"+ ,"FS","GS","RS","US","SP","NUL","SOH","STX","ETX"+ ,"EOT","ENQ","ACK","BEL","DLE","DC1","DC2","DC3"+ ,"DC4","NAK","SYN","ETB","CAN","SUB","ESC","DEL"]+ ("\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP\NUL\SOH" +++ "\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK" +++ "\SYN\ETB\CAN\SUB\ESC\DEL")++pFloat :: Parser Double+pFloat = do+ n <- decNumber+ withDot n <|> noDot n+ where withDot n = do+ _ <- char '.'+ m <- decNumber+ e <- option 1.0 expn+ return ((fromIntegral n + asDec m 0) * e)+ noDot n = do+ e <- expn+ return (fromIntegral n * e)+ expn = do+ _ <- oneOf "eE"+ s <- power+ x <- decNumber+ return (10 ** s (fromIntegral x))+ asDec 0 k = k+ asDec n k =+ asDec (n `div` 10) ((fromIntegral (n `rem` 10) + k) * 0.1)++power :: Num a => Parser (a -> a)+power = negate <$ char '-' <|> id <$ char '+' <|> return id++pInt :: Parser Integer+pInt = do+ s <- power+ n <- pZeroNum <|> decNumber+ return (fromIntegral (s n))++pZeroNum :: Parser Integer+pZeroNum = char '0' >>+ ( (oneOf "xX" >> hexNumber)+ <|> (oneOf "oO" >> octNumber)+ <|> decNumber+ <|> return 0+ )++pHaskLikeAtom :: Parser HaskLikeAtom+pHaskLikeAtom+ = HSFloat <$> (try pFloat <?> "float")+ <|> HSInt <$> (try pInt <?> "integer")+ <|> HSString <$> (pString <?> "string literal")+ <|> HSIdent <$> (parseR5RSIdent <?> "token")++sHaskLikeAtom :: HaskLikeAtom -> Text+sHaskLikeAtom (HSIdent t) = t+sHaskLikeAtom (HSString s) = pack (show s)+sHaskLikeAtom (HSInt i) = pack (show i)+sHaskLikeAtom (HSFloat f) = pack (show f)++-- | This `SExprParser` understands s-expressions that contain+-- Scheme-like tokens, as well as string literals, integer+-- literals, and floating-point literals. Each of these values+-- is parsed according to the lexical rules in the Haskell+-- report, so the same set of string escapes, numeric bases,+-- and floating-point options are available. This spec does+-- not parse comments and does not understand any reader+-- macros.+--+-- >>> decode haskLikeParser "(0x01 \"\\x65lephant\")"+-- Right [SCons (SAtom (HSInt 1)) (SCons (SAtom (HSString "elephant")) SNil)]+haskLikeParser :: SExprParser HaskLikeAtom (SExpr HaskLikeAtom)+haskLikeParser = mkParser pHaskLikeAtom++-- | This 'SExprPrinter' emits s-expressions that contain Scheme-like+-- tokens as well as string literals, integer literals, and floating-point+-- literals, which will be emitted as the literals produced by Haskell's+-- 'show' function. This printer will produce a flat s-expression with+-- no indentation of any kind.+--+-- >>> encode haskLikePrinter [L [A (HSInt 1), A (HSString "elephant")]]+-- "(1 \"elephant\")"+haskLikePrinter :: SExprPrinter HaskLikeAtom (SExpr HaskLikeAtom)+haskLikePrinter = flatPrint sHaskLikeAtom
+ Data/SCargot/Parse.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.SCargot.Parse+ ( -- * Parsing+ decode+ , decodeOne+ -- * Parsing Control+ , SExprParser+ , Reader+ , Comment+ , mkParser+ , setCarrier+ , addReader+ , setComment+ -- * Specific SExprParser Conversions+ , asRich+ , asWellFormed+ , withQuote+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*), pure)+#endif+import Control.Monad ((>=>))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Text (Text)+import Data.String (IsString)+import Text.Parsec ( (<|>)+ , (<?>)+ , char+ , eof+ , lookAhead+ , many1+ , runParser+ , skipMany+ )+import Text.Parsec.Char (anyChar, space)+import Text.Parsec.Text (Parser)++import Data.SCargot.Repr ( SExpr(..)+ , RichSExpr+ , WellFormedSExpr+ , toRich+ , toWellFormed+ )++type ReaderMacroMap atom = Map Char (Reader atom)++-- | A 'Reader' represents a reader macro: it takes a parser for+-- the S-Expression type and performs as much or as little+-- parsing as it would like, and then returns an S-expression.+type Reader atom = (Parser (SExpr atom) -> Parser (SExpr atom))++-- | A 'Comment' represents any kind of skippable comment. This+-- parser __must__ be able to fail if a comment is not being+-- recognized, and it __must__ not consume any input in case+-- of failure.+type Comment = Parser ()++-- | A 'SExprParser' describes a parser for a particular value+-- that has been serialized as an s-expression. The @atom@ parameter+-- corresponds to a Haskell type used to represent the atoms,+-- and the @carrier@ parameter corresponds to the parsed S-Expression+-- structure.+data SExprParser atom carrier = SExprParser+ { sesPAtom :: Parser atom+ , readerMap :: ReaderMacroMap atom+ , comment :: Maybe Comment+ , postparse :: SExpr atom -> Either String carrier+ }++-- | Create a basic 'SExprParser' when given a parser+-- for an atom type.+--+-- >>> import Text.Parsec (alphaNum, many1)+-- >>> let parser = mkParser (many1 alphaNum)+-- >>> decode parser "(ele phant)"+-- Right [SCons (SAtom "ele") (SCons (SAtom "phant") SNil)]+mkParser :: Parser atom -> SExprParser atom (SExpr atom)+mkParser parser = SExprParser+ { sesPAtom = parser+ , readerMap = M.empty+ , comment = Nothing+ , postparse = return+ }++-- | Modify the carrier type for a 'SExprParser'. This is+-- used internally to convert between various 'SExpr' representations,+-- but could also be used externally to add an extra conversion layer+-- onto a 'SExprParser'.+--+-- >>> import Text.Parsec (alphaNum, many1)+-- >>> import Data.SCargot.Repr (toRich)+-- >>> let parser = setCarrier (return . toRich) (mkParser (many1 alphaNum))+-- >>> decode parser "(ele phant)"+-- Right [RSlist [RSAtom "ele",RSAtom "phant"]]+setCarrier :: (b -> Either String c) -> SExprParser a b -> SExprParser a c+setCarrier f spec = spec { postparse = postparse spec >=> f }++-- | Convert the final output representation from the 'SExpr' type+-- to the 'RichSExpr' type.+--+-- >>> import Text.Parsec (alphaNum, many1)+-- >>> let parser = asRich (mkParser (many1 alphaNum))+-- >>> decode parser "(ele phant)"+-- Right [RSlist [RSAtom "ele",RSAtom "phant"]]+asRich :: SExprParser a (SExpr b) -> SExprParser a (RichSExpr b)+asRich = setCarrier (return . toRich)++-- | Convert the final output representation from the 'SExpr' type+-- to the 'WellFormedSExpr' type.+--+-- >>> import Text.Parsec (alphaNum, many1)+-- >>> let parser = asWellFormed (mkParser (many1 alphaNum))+-- >>> decode parser "(ele phant)"+-- Right [WFSList [WFSAtom "ele",WFSAtom "phant"]]+asWellFormed :: SExprParser a (SExpr b) -> SExprParser a (WellFormedSExpr b)+asWellFormed = setCarrier toWellFormed++-- | Add the ability to execute some particular reader macro, as+-- defined by its initial character and the 'Parser' which returns+-- the parsed S-Expression. The 'Reader' is passed a 'Parser' which+-- can be recursively called to parse more S-Expressions, and begins+-- parsing after the reader character has been removed from the+-- stream.+--+-- >>> import Text.Parsec (alphaNum, char, many1)+-- >>> let vecReader p = (char ']' *> pure SNil) <|> (SCons <$> p <*> vecReader p)+-- >>> let parser = addReader '[' vecReader (mkParser (many1 alphaNum))+-- >>> decode parser "(an [ele phant])"+-- Right [SCons (SAtom "an") (SCons (SCons (SAtom "ele") (SCons (SAtom "phant") SNil)) SNil)]++addReader :: Char -> Reader a -> SExprParser a c -> SExprParser a c+addReader c reader spec = spec+ { readerMap = M.insert c reader (readerMap spec) }++-- | Add the ability to ignore some kind of comment. This gets+-- factored into whitespace parsing, and it's very important that+-- the parser supplied __be able to fail__ (as otherwise it will+-- cause an infinite loop), and also that it __not consume any input__+-- (which may require it to be wrapped in 'try'.)+--+-- >>> import Text.Parsec (alphaNum, anyChar, manyTill, many1, string)+-- >>> let comment = string "//" *> manyTill anyChar newline *> pure ()+-- >>> let parser = setComment comment (mkParser (many1 alphaNum))+-- >>> decode parser "(ele //a comment\n phant)"+-- Right [SCons (SAtom "ele") (SCons (SAtom "phant") SNil)]++setComment :: Comment -> SExprParser a c -> SExprParser a c+setComment c spec = spec { comment = Just (c <?> "comment") }++-- | Add the ability to understand a quoted S-Expression.+-- Many Lisps use @'sexpr@ as sugar for @(quote sexpr)@. This+-- assumes that the underlying atom type implements the "IsString"+-- class, and will create the @quote@ atom using @fromString "quote"@.+--+-- >>> import Text.Parsec (alphaNum, many1)+-- >>> let parser = withQuote (mkParser (many1 alphaNum))+-- >>> decode parser "'elephant"+-- Right [SCons (SAtom "quote") (SCons (SAtom "foo") SNil)]+withQuote :: IsString t => SExprParser t (SExpr t) -> SExprParser t (SExpr t)+withQuote = addReader '\'' (fmap go)+ where go s = SCons "quote" (SCons s SNil)++peekChar :: Parser (Maybe Char)+peekChar = Just <$> lookAhead anyChar <|> pure Nothing++parseGenericSExpr ::+ Parser atom -> ReaderMacroMap atom -> Parser () -> Parser (SExpr atom)+parseGenericSExpr atom reader skip = do+ let sExpr = parseGenericSExpr atom reader skip <?> "s-expr"+ skip+ c <- peekChar+ r <- case c of+ Nothing -> fail "Unexpected end of input"+ Just '(' -> char '(' >> skip >> parseList sExpr skip+ Just (flip M.lookup reader -> Just r) -> anyChar >> r sExpr+ _ -> SAtom `fmap` atom+ skip+ return r++parseList :: Parser (SExpr atom) -> Parser () -> Parser (SExpr atom)+parseList sExpr skip = do+ i <- peekChar+ case i of+ Nothing -> fail "Unexpected end of input"+ Just ')' -> char ')' >> return SNil+ _ -> do+ car <- sExpr+ skip+ c <- peekChar+ case c of+ Just '.' -> do+ _ <- char '.'+ cdr <- sExpr+ skip+ _ <- char ')'+ skip+ return (SCons car cdr)+ Just ')' -> do+ _ <- char ')'+ skip+ return (SCons car SNil)+ _ -> do+ cdr <- parseList sExpr skip+ return (SCons car cdr)++-- | Given a CommentMap, create the corresponding parser to+-- skip those comments (if they exist).+buildSkip :: Maybe (Parser ()) -> Parser ()+buildSkip Nothing = skipMany space+buildSkip (Just c) = alternate+ where alternate = skipMany space >> ((c >> alternate) <|> return ())++doParse :: Parser a -> Text -> Either String a+doParse p t = case runParser p () "" t of+ Left err -> Left (show err)+ Right x -> Right x++-- | Decode a single S-expression. If any trailing input is left after+-- the S-expression (ignoring comments or whitespace) then this+-- will fail: for those cases, use 'decode', which returns a list of+-- all the S-expressions found at the top level.+decodeOne :: SExprParser atom carrier -> Text -> Either String carrier+decodeOne spec = doParse (parser <* eof) >=> (postparse spec)+ where parser = parseGenericSExpr+ (sesPAtom spec)+ (readerMap spec)+ (buildSkip (comment spec))++-- | Decode several S-expressions according to a given 'SExprParser'. This+-- will return a list of every S-expression that appears at the top-level+-- of the document.+decode :: SExprParser atom carrier -> Text -> Either String [carrier]+decode spec =+ doParse (many1 parser <* eof) >=> mapM (postparse spec)+ where parser = parseGenericSExpr+ (sesPAtom spec)+ (readerMap spec)+ (buildSkip (comment spec))++{-+-- | Encode (without newlines) a single S-expression.+encodeSExpr :: SExpr atom -> (atom -> Text) -> Text+encodeSExpr SNil _ = "()"+encodeSExpr (SAtom s) t = t s+encodeSExpr (SCons x xs) t = go xs (encodeSExpr x t)+ where go (SAtom s) rs = "(" <> rs <> " . " <> t s <> ")"+ go SNil rs = "(" <> rs <> ")"+ go (SCons x xs) rs = go xs (rs <> " " <> encodeSExpr x t)++-- | Emit an S-Expression in a machine-readable way. This does no+-- pretty-printing or indentation, and produces no comments.+encodeOne :: SExprParser atom carrier -> carrier -> Text+encodeOne spec c = encodeSExpr (preserial spec c) (sesSAtom spec)++encode :: SExprParser atom carrier -> [carrier] -> Text+encode spec cs = T.concat (map (encodeOne spec) cs)+-}
+ Data/SCargot/Print.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.SCargot.Print+ ( -- * Pretty-Printing+ encodeOne+ , encode+ -- * Pretty-Printing Control+ , SExprPrinter+ , Indent(..)+ , setFromCarrier+ , setMaxWidth+ , removeMaxWidth+ , setIndentAmount+ , setIndentStrategy+ -- * Default Printing Strategies+ , basicPrint+ , flatPrint+ ) where++import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T++import Data.SCargot.Repr++-- | The 'Indent' type is used to determine how to indent subsequent+-- s-expressions in a list, after printing the head of the list.+data Indent+ = Swing -- ^ A 'Swing' indent will indent subsequent exprs some fixed+ -- amount more than the current line.+ --+ -- > (foo+ -- > bar+ -- > baz+ -- > quux)+ | SwingAfter Int -- ^ A 'SwingAfter' @n@ indent will try to print the+ -- first @n@ expressions after the head on the same+ -- line as the head, and all after will be swung.+ -- 'SwingAfter' @0@ is equivalent to 'Swing'.+ --+ -- > (foo bar+ -- > baz+ -- > quux)+ | Align -- ^ An 'Align' indent will print the first expression after+ -- the head on the same line, and subsequent expressions will+ -- be aligned with that one.+ --+ -- > (foo bar+ -- > baz+ -- > quux)+ deriving (Eq, Show)++-- | A 'SExprPrinter' value describes how to print a given value as an+-- s-expression. The @carrier@ type parameter indicates the value+-- that will be printed, and the @atom@ parameter indicates the type+-- that will represent tokens in an s-expression structure.+data SExprPrinter atom carrier = SExprPrinter+ { atomPrinter :: atom -> Text+ -- ^ How to serialize a given atom to 'Text'.+ , fromCarrier :: carrier -> SExpr atom+ -- ^ How to turn a carrier type back into a 'Sexpr'.+ , swingIndent :: SExpr atom -> Indent+ -- ^ How to indent subsequent expressions, as determined by+ -- the head of the list.+ , indentAmount :: Int+ -- ^ How much to indent after a swung indentation.+ , maxWidth :: Maybe Int+ -- ^ The maximum width (if any) If this is 'None' then+ -- the resulting s-expression will always be printed+ -- on a single line.+ }++-- | A default 'LayoutOptions' struct that will always print a 'SExpr'+-- as a single line.+flatPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)+flatPrint printer = SExprPrinter+ { atomPrinter = printer+ , fromCarrier = id+ , swingIndent = const Swing+ , indentAmount = 2+ , maxWidth = Nothing+ }++-- | A default 'LayoutOptions' struct that will always swing subsequent+-- expressions onto later lines if they're too long, indenting them+-- by two spaces.+basicPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)+basicPrint printer = SExprPrinter+ { atomPrinter = printer+ , fromCarrier = id+ , swingIndent = const Swing+ , indentAmount = 2+ , maxWidth = Just 80+ }++-- | Modify the carrier type of a 'SExprPrinter' by describing how+-- to convert the new type back to the previous type. For example,+-- to pretty-print a well-formed s-expression, we can modify the+-- 'SExprPrinter' value as follows:+--+-- >>> let printer = setFromCarrier fromWellFormed (basicPrint id)+-- >>> encodeOne printer (WFSList [WFSAtom "ele", WFSAtom "phant"])+-- "(ele phant)"+setFromCarrier :: (c -> b) -> SExprPrinter a b -> SExprPrinter a c+setFromCarrier fc pr = pr { fromCarrier = fromCarrier pr . fc }++-- | Dictate a maximum width for pretty-printed s-expressions.+--+-- >>> let printer = setMaxWidth 8 (basicPrint id)+-- >>> encodeOne printer (L [A "one", A "two", A "three"])+-- "(one \n two\n three)"+setMaxWidth :: Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier+setMaxWidth n pr = pr { maxWidth = Just n }++-- | Allow the serialized s-expression to be arbitrarily wide. This+-- makes all pretty-printing happen on a single line.+--+-- >>> let printer = removeMaxWidth (basicPrint id)+-- >>> encodeOne printer (L [A "one", A "two", A "three"])+-- "(one two three)"+removeMaxWidth :: SExprPrinter atom carrier -> SExprPrinter atom carrier+removeMaxWidth pr = pr { maxWidth = Nothing }++-- | Set the number of spaces that a subsequent line will be indented+-- after a swing indentation.+--+-- >>> let printer = setMaxWidth 12 (basicPrint id)+-- >>> encodeOne printer (L [A "elephant", A "pachyderm"])+-- "(elephant \n pachyderm)"+-- >>> encodeOne (setIndentAmount 4) (L [A "elephant", A "pachyderm"])+-- "(elephant \n pachyderm)"+setIndentAmount :: Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier+setIndentAmount n pr = pr { indentAmount = n }++-- | Dictate how to indent subsequent lines based on the leading+-- subexpression in an s-expression. For details on how this works,+-- consult the documentation of the 'Indent' type.+--+-- >>> let indent (A "def") = SwingAfter 1; indent _ = Swing+-- >>> let printer = setIndentStrategy indent (setMaxWidth 8 (basicPrint id))+-- >>> encodeOne printer (L [ A "def", L [ A "func", A "arg" ], A "body" ])+-- "(def (func arg)\n body)"+-- >>> encodeOne printer (L [ A "elephant", A "among", A "pachyderms" ])+-- "(elephant \n among\n pachyderms)"+setIndentStrategy :: (SExpr atom -> Indent) -> SExprPrinter atom carrier -> SExprPrinter atom carrier+setIndentStrategy st pr = pr { swingIndent = st }++-- Sort of like 'unlines' but without the trailing newline+joinLines :: [Text] -> Text+joinLines = T.intercalate "\n"++-- Indents a line by n spaces+indent :: Int -> Text -> Text+indent n ts = T.replicate n " " <> ts++-- Indents every line n spaces, and adds a newline to the beginning+-- used in swung indents+indentAll :: Int -> [Text] -> Text+indentAll n = ("\n" <>) . joinLines . map (indent n)++-- Indents every line but the first by some amount+-- used in aligned indents+indentSubsequent :: Int -> [Text] -> Text+indentSubsequent _ [] = ""+indentSubsequent _ [t] = t+indentSubsequent n (t:ts) = joinLines (t : go ts)+ where go = map (indent n)++-- oh god this code is so disgusting+-- i'm sorry to everyone i let down by writing this+-- i swear i'll do better in the future i promise i have to+-- for my sake and for everyone's++-- | Pretty-print a 'SExpr' according to the options in a+-- 'LayoutOptions' value.+prettyPrintSExpr :: SExprPrinter a (SExpr a) -> SExpr a -> Text+prettyPrintSExpr SExprPrinter { .. } = pHead 0+ where pHead _ SNil = "()"+ pHead _ (SAtom a) = atomPrinter a+ pHead ind (SCons x xs) = gather ind x xs id+ gather _ _ (SAtom _) _ = error "no dotted pretty printing yet!"+ gather ind h (SCons x xs) k = gather ind h xs (k . (x:))+ gather ind h SNil k = "(" <> hd <> body <> ")"+ where hd = indentSubsequent ind [pHead (ind+1) h]+ lst = k []+ flat = T.unwords (map (pHead (ind+1)) lst)+ headWidth = T.length hd + 1+ indented =+ case swingIndent h of+ SwingAfter n ->+ let (l, ls) = splitAt n lst+ t = T.unwords (map (pHead (ind+1)) l)+ ts = indentAll (ind + indentAmount)+ (map (pHead (ind + indentAmount)) ls)+ in t <> ts+ Swing ->+ indentAll (ind + indentAmount)+ (map (pHead (ind + indentAmount)) lst)+ Align ->+ indentSubsequent (ind + headWidth + 1)+ (map (pHead (ind + headWidth + 1)) lst)+ body+ | length lst == 0 = ""+ | Just maxAmt <- maxWidth+ , T.length flat + ind > maxAmt = " " <> indented+ | otherwise = " " <> flat++-- | Turn a single s-expression into a string according to a given+-- 'SExprPrinter'.+encodeOne :: SExprPrinter atom carrier -> carrier -> Text+encodeOne s@(SExprPrinter { .. }) =+ prettyPrintSExpr (s { fromCarrier = id }) . fromCarrier++-- | Turn a list of s-expressions into a single string according to+-- a given 'SExprPrinter'.+encode :: SExprPrinter atom carrier -> [carrier] -> Text+encode spec = T.intercalate "\n\n" . map (encodeOne spec)
+ Data/SCargot/Repr.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}++module Data.SCargot.Repr+ ( -- $reprs+ -- * Elementary SExpr representation+ SExpr(..)+ -- * Rich SExpr representation+ , RichSExpr(..)+ , toRich+ , fromRich+ -- * Well-Formed SExpr representation+ , WellFormedSExpr(..)+ , toWellFormed+ , fromWellFormed+ ) where++import Data.Data (Data)+import Data.Foldable (Foldable(..))+import Data.Traversable (Traversable(..))+import Data.Typeable (Typeable)+import GHC.Exts (IsList(..), IsString(..))++#if !MIN_VERSION_base(4,8,0)+import Prelude hiding (foldr)+#endif++-- | All S-Expressions can be understood as a sequence+-- of @cons@ cells (represented here by 'SCons'), the+-- empty list @nil@ (represented by 'SNil') or an+-- @atom@.+data SExpr atom+ = SCons (SExpr atom) (SExpr atom)+ | SAtom atom+ | SNil+ deriving (Eq, Show, Read, Functor, Data, Typeable, Foldable, Traversable)++instance IsString atom => IsString (SExpr atom) where+ fromString = SAtom . fromString++instance IsList (SExpr atom) where+ type Item (SExpr atom) = SExpr atom+ fromList = foldr SCons SNil+ toList = go+ where go (SCons x xs) = x : go xs+ go SNil = []+ go (SAtom {}) = error "Unable to turn atom into list"++-- | Sometimes the cons-based interface is too low+-- level, and we'd rather have the lists themselves+-- exposed. In this case, we have 'RSList' to+-- represent a well-formed cons list, and 'RSDotted'+-- to represent an improper list of the form+-- @(a b c . d)@. This representation is based on+-- the structure of the parsed S-Expression, and not on+-- how it was originally represented: thus, @(a . (b))@ is going to+-- be represented as @RSList[RSAtom a, RSAtom b]@+-- despite having been originally represented as a+-- dotted list.+data RichSExpr atom+ = RSList [RichSExpr atom]+ | RSDotted [RichSExpr atom] atom+ | RSAtom atom+ deriving (Eq, Show, Read, Functor, Data, Typeable, Foldable, Traversable)++instance IsString atom => IsString (RichSExpr atom) where+ fromString = RSAtom . fromString++instance IsList (RichSExpr atom) where+ type Item (RichSExpr atom) = RichSExpr atom+ fromList = RSList+ toList (RSList xs) = xs+ toList (RSDotted {}) = error "Unable to turn dotted list into haskell list"+ toList (RSAtom {}) = error "Unable to turn atom into Haskell list"++-- | It should always be true that+--+-- > fromRich (toRich x) == x+--+-- and that+--+-- > toRich (fromRich x) == x+toRich :: SExpr atom -> RichSExpr atom+toRich (SAtom a) = RSAtom a+toRich (SCons x xs) = go xs (toRich x:)+ where go (SAtom a) rs = RSDotted (rs []) a+ go SNil rs = RSList (rs [])+ go (SCons y ys) rs = go ys (rs . (toRich y:))+toRich SNil = RSList []++-- | This follows the same laws as 'toRich'.+fromRich :: RichSExpr atom -> SExpr atom+fromRich (RSAtom a) = SAtom a+fromRich (RSList xs) = foldr SCons SNil (map fromRich xs)+fromRich (RSDotted xs x) = foldr SCons (SAtom x) (map fromRich xs)++-- | A well-formed s-expression is one which does not+-- contain any dotted lists. This means that not+-- every value of @SExpr a@ can be converted to a+-- @WellFormedSExpr a@, although the opposite is+-- fine.+data WellFormedSExpr atom+ = WFSList [WellFormedSExpr atom]+ | WFSAtom atom+ deriving (Eq, Show, Read, Functor, Data, Typeable, Foldable, Traversable)++instance IsList (WellFormedSExpr atom) where+ type Item (WellFormedSExpr atom) = WellFormedSExpr atom+ fromList = WFSList+ toList (WFSList xs) = xs+ toList (WFSAtom {}) = error "Unable to turn atom into Haskell list"++instance IsString atom => IsString (WellFormedSExpr atom) where+ fromString = WFSAtom . fromString++-- | This will be @Nothing@ if the argument contains an+-- improper list. It should hold that+--+-- > toWellFormed (fromWellFormed x) == Right x+--+-- and also (more tediously) that+--+-- > case toWellFormed x of+-- > Left _ -> True+-- > Right y -> x == fromWellFormed y+toWellFormed :: SExpr atom -> Either String (WellFormedSExpr atom)+toWellFormed SNil = return (WFSList [])+toWellFormed (SAtom a) = return (WFSAtom a)+toWellFormed (SCons x xs) = do+ x' <- toWellFormed x+ go xs (x':)+ where go (SAtom _) _ = Left "Found atom in cdr position"+ go SNil rs = return (WFSList (rs []))+ go (SCons y ys) rs = do+ y' <- toWellFormed y+ go ys (rs . (y':))++-- | Convert a WellFormedSExpr back into a SExpr.+fromWellFormed :: WellFormedSExpr atom -> SExpr atom+fromWellFormed (WFSAtom a) = SAtom a+fromWellFormed (WFSList xs) =+ foldr SCons SNil (map fromWellFormed xs)++{- $reprs++This module contains several different representations for+s-expressions. The s-cargot library underlying uses the+'SExpr' type as its representation type, which is a binary+tree representation with an arbitrary type for its leaves.++This type is not always convenient to manipulate in Haskell+code, this module defines two alternate representations+which turn a sequence of nested right-branching cons pairs+into Haskell lists: that is to say, they transform between++@+SCons a (SCons b (SCons c SNil)) \<=\> RSList [a, b, c]+@++These two types differ in how they handle non-well-formed+lists, i.e. lists that end with an atom. The 'RichSExpr'+format handles this with a special constructor for lists+that end in an atom:++@+SCons a (SCons b (SAtom c)) \<=\> RSDotted [a, b] c+@++On the other hand, the 'WellFormedSExpr' type elects+not to handle this case. This is unusual for Lisp source code,+but is a reasonable choice for configuration or data+storage formats that use s-expressions, where+non-well-formed lists would be an unnecessary+complication.++To make working with these types less verbose, there are other+modules that export pattern aliases and helper functions: these+can be found at "Data.SCargot.Repr.Basic",+"Data.SCargot.Repr.Rich", and "Data.SCargot.Repr.WellFormed".+-}
+ Data/SCargot/Repr/Basic.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module Data.SCargot.Repr.Basic+ ( -- * Basic 'SExpr' representation+ R.SExpr(..)+ -- * Constructing and Deconstructing+ , cons+ , uncons+ -- * Shorthand Patterns+ , pattern (:::)+ , pattern A+ , pattern L+ , pattern DL+ , pattern Nil+ -- * Lenses+ , _car+ , _cdr+ -- * Useful processing functions+ , fromPair+ , fromList+ , fromAtom+ , asPair+ , asList+ , isAtom+ , asAtom+ , asAssoc+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative, (<$>), (<*>), pure)+#endif+import Data.SCargot.Repr as R++-- | A traversal with access to the first element of a pair.+--+-- >>> import Lens.Family+-- >>> set _car (A "elephant") (A "one" ::: A "two" ::: A "three" ::: Nil)+-- A "elelphant" ::: A "two" ::: A "three" ::: Nil+-- >>> set _car (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")+-- (A "two" ::: A "three" ::: Nil) ::: A "elephant"+_car :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)+_car f (SCons x xs) = (:::) <$> f x <*> pure xs+_car _ (SAtom a) = pure (A a)+_car _ SNil = pure SNil++-- | A traversal with access to the second element of a pair.+--+-- >>> import Lens.Family+-- >>> set _cdr (A "elephant") (A "one" ::: A "two" ::: A "three" ::: Nil)+-- A "one" ::: A "elephant"+-- >>> set _cdr (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")+-- A "one" ::: A "two" ::: A "three" ::: Nil+_cdr :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)+_cdr f (SCons x xs) = (:::) <$> pure x <*> f xs+_cdr _ (SAtom a) = pure (A a)+_cdr _ SNil = pure Nil++-- | Produce the head and tail of the s-expression (if possible).+--+-- >>> uncons (A "el" ::: A "eph" ::: A "ant" ::: Nil)+-- Just (A "el",SCons (SAtom "eph") (SCons (SAtom "ant") SNil))+uncons :: SExpr a -> Maybe (SExpr a, SExpr a)+uncons (SCons x xs) = Just (x, xs)+uncons _ = Nothing++-- | Combine the two s-expressions into a new one.+--+-- >>> cons (A "el") (L ["eph", A "ant"])+-- SCons (SAtom "el) (SCons (SAtom "eph") (SCons (SAtom "ant") SNil))+cons :: SExpr a -> SExpr a -> SExpr a+cons = SCons++mkList :: [SExpr a] -> SExpr a+mkList [] = SNil+mkList (x:xs) = SCons x (mkList xs)++mkDList :: [SExpr a] -> a -> SExpr a+mkDList [] a = SAtom a+mkDList (x:xs) a = SCons x (mkDList xs a)++gatherDList :: SExpr a -> Maybe ([SExpr a], a)+gatherDList SNil = Nothing+gatherDList SAtom {} = Nothing+gatherDList sx = go sx+ where go SNil = Nothing+ go (SAtom a) = return ([], a)+ go (SCons x xs) = do+ (ys, a) <- go xs+ return (x:ys, a)++infixr 5 :::++-- | A shorter infix alias for `SCons`+--+-- >>> A "pachy" ::: A "derm"+-- SCons (SAtom "pachy") (SAtom "derm")+pattern x ::: xs = SCons x xs++-- | A shorter alias for `SAtom`+--+-- >>> A "elephant"+-- SAtom "elephant"+pattern A x = SAtom x++-- | A (slightly) shorter alias for `SNil`+--+-- >>> Nil+-- SNil+pattern Nil = SNil++-- | An alias for matching a proper list.+--+-- >>> L [A "pachy", A "derm"]+-- SCons (SAtom "pachy") (SCons (SAtom "derm") SNil)+pattern L xs <- (gatherList -> Right xs)+#if MIN_VERSION_base(4,8,0)+ where L xs = mkList xs+#endif+++-- | An alias for matching a dotted list.+--+-- >>> DL [A "pachy"] A "derm"+-- SCons (SAtom "pachy") (SAtom "derm")+pattern DL xs x <- (gatherDList -> Just (xs, x))+#if MIN_VERSION_base(4,8,0)+ where DL xs x = mkDList xs x+#endif++getShape :: SExpr a -> String+getShape Nil = "empty list"+getShape sx = go (0 :: Int) sx+ where go n SNil = "list of length " ++ show n+ go n SAtom {} = "dotted list of length " ++ show n+ go n (SCons _ xs) = go (n+1) xs++-- | Utility function for parsing a pair of things.+--+-- >>> fromPair (isAtom "pachy") (asAtom return) (A "pachy" ::: A "derm" ::: Nil)+-- Right ((), "derm")+-- >>> fromPair (isAtom "pachy") fromAtom (A "pachy" ::: Nil)+-- Left "Expected two-element list"+fromPair :: (SExpr t -> Either String a)+ -> (SExpr t -> Either String b)+ -> SExpr t -> Either String (a, b)+fromPair pl pr (l ::: r ::: Nil) = (,) <$> pl l <*> pr r+fromPair _ _ sx = Left ("fromPair: expected two-element list; found " ++ getShape sx)++-- | Utility function for parsing a list of things.+fromList :: (SExpr t -> Either String a) -> SExpr t -> Either String [a]+fromList p (s ::: ss) = (:) <$> p s <*> fromList p ss+fromList _ Nil = pure []+fromList _ sx = Left ("fromList: expected list; found " ++ getShape sx)++-- | Utility function for parsing a single atom+fromAtom :: SExpr t -> Either String t+fromAtom (A a) = return a+fromAtom sx = Left ("fromAtom: expected atom; found list" ++ getShape sx)++gatherList :: SExpr t -> Either String [SExpr t]+gatherList (x ::: xs) = (:) <$> pure x <*> gatherList xs+gatherList Nil = pure []+gatherList sx = Left ("gatherList: expected list; found " ++ getShape sx)++-- | Parse a two-element list (NOT a dotted pair) using the+-- provided function.+--+-- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"+-- >>> asPair go (A "pachy" ::: A "derm" ::: Nil)+-- Right "pachyderm"+-- >>> asPair go (A "elephant" ::: Nil)+-- Left "asPair: expected two-element list; found list of length 1"+asPair :: ((SExpr t, SExpr t) -> Either String a)+ -> SExpr t -> Either String a+asPair f (l ::: r ::: SNil) = f (l, r)+asPair _ sx = Left ("asPair: expected two-element list; found " ++ getShape sx)++-- | Parse an arbitrary-length list using the provided function.+--+-- >>> let go xs = concat <$> mapM fromAtom xs+-- >>> asList go (A "el" ::: A "eph" ::: A "ant" ::: Nil)+-- Right "elephant"+-- >>> asList go (A "el" ::: A "eph" ::: A "ant")+-- Left "asList: expected list; found dotted list of length 3"+asList :: ([SExpr t] -> Either String a) -> SExpr t -> Either String a+asList f ls = gatherList ls >>= f++-- | Match a given literal atom, failing otherwise.+--+-- >>> isAtom "elephant" (A "elephant")+-- Right ()+-- >>> isAtom "elephant" (A "elephant" ::: Nil)+-- Left "isAtom: expected atom; found list"+isAtom :: Eq t => t -> SExpr t -> Either String ()+isAtom s (A s')+ | s == s' = return ()+ | otherwise = Left "isAtom: failed to match atom"+isAtom _ sx = Left ("isAtom: expected atom; found " ++ getShape sx)++-- | Parse an atom using the provided function.+--+-- >>> import Data.Char (toUpper)+-- >>> asAtom (return . map toUpper) (A "elephant")+-- Right "ELEPHANT"+-- >>> asAtom (return . map toUpper) Nil+-- Left "asAtom: expected atom; found empty list"+asAtom :: (t -> Either String a) -> SExpr t -> Either String a+asAtom f (A s) = f s+asAtom _ sx = Left ("asAtom: expected atom; found " ++ getShape sx)++-- | Parse an assoc-list using the provided function.+--+-- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }+-- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }+-- >>> asAssoc defList ((A "legs" ::: A "four" ::: Nil) ::: (A "trunk" ::: A "one" ::: Nil) ::: Nil)+-- Right "legs: four\ntrunk: one\n"+-- >>> asAssoc defList ((A "legs" ::: A "four" ::: Nil) ::: (A "elephant") ::: Nil)+-- Left "asAssoc: expected pair; found list of length 1"+asAssoc :: ([(SExpr t, SExpr t)] -> Either String a)+ -> SExpr t -> Either String a+asAssoc f ss = gatherList ss >>= mapM go >>= f+ where go (a ::: b ::: Nil) = return (a, b)+ go sx = Left ("asAssoc: expected pair; found " ++ getShape sx)
+ Data/SCargot/Repr/Rich.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module Data.SCargot.Repr.Rich+ ( -- * 'RichSExpr' representation+ R.RichSExpr(..)+ , R.toRich+ , R.fromRich+ -- * Constructing and Deconstructing+ , cons+ , uncons+ -- * Useful pattern synonyms+ , pattern (:::)+ , pattern A+ , pattern L+ , pattern DL+ , pattern Nil+ -- * Lenses+ , _car+ , _cdr+ -- * Useful processing functions+ , fromPair+ , fromList+ , fromAtom+ , asPair+ , asList+ , isAtom+ , isNil+ , asAtom+ , asAssoc+ , car+ , cdr+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative, (<$>), (<*>), pure)+#endif+import Data.SCargot.Repr as R++-- | A traversal with access to the first element of a pair.+--+-- >>> import Lens.Family+-- >>> set _car (A "elephant") (L [A "one", A "two", A "three"])+-- L [A "elelphant",A "two",A "three"]+-- >>> set _car (L [A "two", A "three"]) (DL [A "one"] "elephant")+-- DL [L[A "two",A "three"]] "elephant"+_car :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)+_car f (RSList (x:xs)) = (\ y -> L (y:xs)) `fmap` f x+_car f (RSDotted (x:xs) a) = (\ y -> DL (y:xs) a) `fmap` f x+_car _ (RSAtom a) = pure (A a)+_car _ (RSList []) = pure Nil+_car _ (RSDotted [] a) = pure (A a)++-- | A traversal with access to the second element of a pair. Using+-- this to modify an s-expression may result in changing the+-- constructor used, changing a list to a dotted list or vice+-- versa.+--+-- >>> import Lens.Family+-- >>> set _cdr (A "elephant") (L [A "one", A "two", A "three"])+-- DL [A "one"] "elephant"+-- >>> set _cdr (L [A "two", A "three"]) (DL [A "one"] "elephant")+-- L [A "one",A "two",A "three"]+_cdr :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)+_cdr f (RSList (x:xs)) =+ let go (RSList []) = L [x]+ go (RSAtom a) = DL [x] a+ go (RSList xs') = L (x:xs')+ go (RSDotted ys a') = DL (x:ys) a'+ in go `fmap` f (L xs)+_cdr f (RSDotted [x] a) =+ let go (RSList []) = L [x]+ go (RSAtom a') = DL [x] a'+ go (RSList xs) = L (x:xs)+ go (RSDotted ys a') = DL (x:ys) a'+ in go `fmap` f (A a)+_cdr f (RSDotted (x:xs) a) =+ let go (RSList []) = L [x]+ go (RSAtom a') = DL [x] a'+ go (RSList ys) = L (x:ys)+ go (RSDotted ys a') = DL (x:ys) a'+ in go `fmap` f (DL xs a)+_cdr _ (RSAtom a) = pure (A a)+_cdr _ (RSList []) = pure Nil+_cdr _ (RSDotted [] a) = pure (A a)++-- | Produce the head and tail of the s-expression (if possible).+--+-- >>> uncons (L [A "el", A "eph", A "ant"])+-- Just (A "el",L [A "eph",A "ant"])+uncons :: RichSExpr a -> Maybe (RichSExpr a, RichSExpr a)+uncons (R.RSList (x:xs)) = Just (x, R.RSList xs)+uncons (R.RSDotted (x:xs) a) = Just (x, R.RSDotted xs a)+uncons _ = Nothing++-- | Combine the two s-expressions into a new one.+--+-- >>> cons (A "el") (L [A "eph", A "ant"])+-- L [A "el",A "eph",A "ant"]+cons :: RichSExpr a -> RichSExpr a -> RichSExpr a+cons x (R.RSList xs) = R.RSList (x:xs)+cons x (R.RSDotted xs a) = R.RSDotted (x:xs) a+cons x (R.RSAtom a) = R.RSDotted [x] a++-- | A shorter infix alias to grab the head+-- and tail of an `RSList`.+--+-- >>> A "one" ::: L [A "two", A "three"]+-- RSList [RSAtom "one",RSAtom "two",RSAtom "three"]+pattern x ::: xs <- (uncons -> Just (x, xs))+#if MIN_VERSION_base(4,8,0)+ where x ::: xs = cons x xs+#endif++-- | A shorter alias for `RSAtom`+--+-- >>> A "elephant"+-- RSAtom "elephant"+pattern A a = R.RSAtom a++-- | A shorter alias for `RSList`+--+-- >>> L [A "pachy", A "derm"]+-- RSList [RSAtom "pachy",RSAtom "derm"]+pattern L xs = R.RSList xs++-- | A shorter alias for `RSDotted`+--+-- >>> DL [A "pachy"] "derm"+-- RSDotted [RSAtom "pachy"] "derm"+pattern DL xs x = R.RSDotted xs x++-- | A shorter alias for `RSList` @[]@+--+-- >>> Nil+-- RSList []+pattern Nil = R.RSList []++-- | Utility function for parsing a pair of things: this parses a two-element list,+-- and not a cons pair.+--+-- >>> fromPair (isAtom "pachy") (asAtom return) (L [A "pachy", A "derm"])+-- Right ((), "derm")+-- >>> fromPair (isAtom "pachy") fromAtom (L [A "pachy"])+-- Left "Expected two-element list"+fromPair :: (RichSExpr t -> Either String a)+ -> (RichSExpr t -> Either String b)+ -> RichSExpr t -> Either String (a, b)+fromPair pl pr = asPair $ \(l,r) -> (,) <$> pl l <*> pr r++-- | Utility function for parsing a proper list of things.+--+-- >>> fromList fromAtom (L [A "this", A "that", A "the-other"])+-- Right ["this","that","the-other"]+-- >>> fromList fromAtom (DL [A "this", A "that"] "the-other"])+-- Left "asList: expected proper list; found dotted list"+fromList :: (RichSExpr t -> Either String a) -> RichSExpr t -> Either String [a]+fromList p = asList $ \ss -> mapM p ss++-- | Utility function for parsing a single atom+--+-- >>> fromAtom (A "elephant")+-- Right "elephant"+-- >>> fromAtom (L [A "elephant"])+-- Left "fromAtom: expected atom; found list"+fromAtom :: RichSExpr t -> Either String t+fromAtom (RSList _) = Left "fromAtom: expected atom; found list"+fromAtom (RSDotted _ _) = Left "fromAtom: expected atom; found dotted list"+fromAtom (RSAtom a) = return a++-- | Parses a two-element list using the provided function.+--+-- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"+-- >>> asPair go (L [A "pachy", A "derm"])+-- Right "pachyderm"+-- >>> asPair go (L [A "elephant"])+-- Left "asPair: expected two-element list; found list of length 1"+asPair :: ((RichSExpr t, RichSExpr t) -> Either String a)+ -> RichSExpr t -> Either String a+asPair f (RSList [l, r]) = f (l, r)+asPair _ (RSList ls) = Left ("asPair: expected two-element list; found list of lenght " ++ show (length ls))+asPair _ RSDotted {} = Left ("asPair: expected two-element list; found dotted list")+asPair _ RSAtom {} = Left ("asPair: expected two-element list; found atom")++-- | Parse an arbitrary-length list using the provided function.+--+-- >>> let go xs = concat <$> mapM fromAtom xs+-- >>> asList go (L [A "el", A "eph", A "ant"])+-- Right "elephant"+-- >>> asList go (DL [A "el", A "eph"] "ant")+-- Left "asList: expected list; found dotted list"+asList :: ([RichSExpr t] -> Either String a)+ -> RichSExpr t -> Either String a+asList f (RSList ls) = f ls+asList _ RSDotted {} = Left ("asList: expected list; found dotted list")+asList _ RSAtom { } = Left ("asList: expected list; found dotted list")++-- | Match a given literal atom, failing otherwise.+--+-- >>> isAtom "elephant" (A "elephant")+-- Right ()+-- >>> isAtom "elephant" (L [A "elephant"])+-- Left "isAtom: expected atom; found list"+isAtom :: Eq t => t -> RichSExpr t -> Either String ()+isAtom s (RSAtom s')+ | s == s' = return ()+ | otherwise = Left "isAtom: failed to match atom"+isAtom _ RSList {} = Left "isAtom: expected atom; found list"+isAtom _ RSDotted {} = Left "isAtom: expected atom; found dotted list"++-- | Match an empty list, failing otherwise.+--+-- >>> isNil (L [])+-- Right ()+-- >>> isNil (A "elephant")+-- Left "isNil: expected nil; found atom"+isNil :: RichSExpr t -> Either String ()+isNil (RSList []) = return ()+isNil RSList {} = Left "isNil: expected nil; found non-nil list"+isNil RSDotted {} = Left "isNil: expected nil; found dotted list"+isNil RSAtom {} = Left "isNil: expected nil; found atom"++-- | Parse an atom using the provided function.+--+-- >>> import Data.Char (toUpper)+-- >>> asAtom (return . map toUpper) (A "elephant")+-- Right "ELEPHANT"+-- >>> asAtom (return . map toUpper) (L [])+-- Left "asAtom: expected atom; found list"+asAtom :: (t -> Either String a) -> RichSExpr t -> Either String a+asAtom f (RSAtom s) = f s+asAtom _ RSList {} = Left ("asAtom: expected atom; found list")+asAtom _ RSDotted {} = Left ("asAtom: expected atom; found dotted list")++-- | Parse an assoc-list using the provided function.+--+-- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }+-- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }+-- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "trunk", A "one"] ])+-- Right "legs: four\ntrunk: one\n"+-- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "elephant"] ])+-- Left "asAssoc: expected pair; found list of length 1"+asAssoc :: ([(RichSExpr t, RichSExpr t)] -> Either String a)+ -> RichSExpr t -> Either String a+asAssoc f (RSList ss) = gatherPairs ss >>= f+ where gatherPairs (RSList [a, b] : ts) = (:) <$> pure (a, b) <*> gatherPairs ts+ gatherPairs [] = pure []+ gatherPairs (RSAtom {} : _) = Left ("asAssoc: expected pair; found atom")+ gatherPairs (RSDotted {} : _) = Left ("asAssoc: expected pair; found dotted list")+ gatherPairs (RSList ls : _) = Left ("asAssoc: expected pair; found list of length " ++ show (length ls))+asAssoc _ RSDotted {} = Left "asAssoc: expected assoc list; found dotted list"+asAssoc _ RSAtom {} = Left "asAssoc: expected assoc list; found atom"++car :: (RichSExpr t -> Either String t') -> [RichSExpr t] -> Either String t'+car f (x:_) = f x+car _ [] = Left "car: Taking car of zero-element list"++cdr :: ([RichSExpr t] -> Either String t') -> [RichSExpr t] -> Either String t'+cdr f (_:xs) = f xs+cdr _ [] = Left "cdr: Taking cdr of zero-element list"
+ Data/SCargot/Repr/WellFormed.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module Data.SCargot.Repr.WellFormed+ ( -- * 'WellFormedSExpr' representation+ R.WellFormedSExpr(..)+ , R.toWellFormed+ , R.fromWellFormed+ -- * Constructing and Deconstructing+ , cons+ , uncons+ -- * Useful pattern synonyms+ , pattern (:::)+ , pattern L+ , pattern A+ , pattern Nil+ -- * Useful processing functions+ , fromPair+ , fromList+ , fromAtom+ , asPair+ , asList+ , isAtom+ , isNil+ , asAtom+ , asAssoc+ , car+ , cdr+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>), pure)+#endif+import Data.SCargot.Repr as R++-- | Produce the head and tail of the s-expression (if possible).+--+-- >>> uncons (L [A "el", A "eph", A "ant"])+-- Just (WFSAtom "el",WFSList [WFSAtom "eph",WFSAtom "ant"])+uncons :: WellFormedSExpr a -> Maybe (WellFormedSExpr a, WellFormedSExpr a)+uncons R.WFSAtom {} = Nothing+uncons (R.WFSList []) = Nothing+uncons (R.WFSList (x:xs)) = Just (x, R.WFSList xs)++-- | Combine the two-expressions into a new one. This will return+-- @Nothing@ if the resulting s-expression is not well-formed.+--+-- >>> cons (A "el") (L [A "eph", A "ant"])+-- Just (WFSList [WFSAtom "el",WFSAtom "eph",WFSAtom "ant"])+-- >>> cons (A "pachy") (A "derm"))+-- Nothing+cons :: WellFormedSExpr a -> WellFormedSExpr a -> Maybe (WellFormedSExpr a)+cons _ (R.WFSAtom {}) = Nothing+cons x (R.WFSList xs) = Just (R.WFSList (x:xs))++-- | A shorter infix alias to grab the head and tail of a `WFSList`. This+-- pattern is unidirectional, because it cannot be guaranteed that it+-- is used to construct well-formed s-expressions; use the function "cons"+-- instead.+--+-- >>> let sum (x ::: xs) = x + sum xs; sum Nil = 0+pattern x ::: xs <- (uncons -> Just (x, xs))++-- | A shorter alias for `WFSList`+--+-- >>> L [A "pachy", A "derm"]+-- WFSList [WFSAtom "pachy",WFSAtom "derm"]+pattern L xs = R.WFSList xs++-- | A shorter alias for `WFSAtom`+--+-- >>> A "elephant"+-- WFSAtom "elephant"+pattern A a = R.WFSAtom a++-- | A shorter alias for `WFSList` @[]@+--+-- >>> Nil+-- WFSList []+pattern Nil = R.WFSList []++getShape :: WellFormedSExpr a -> String+getShape WFSAtom {} = "atom"+getShape (WFSList []) = "empty list"+getShape (WFSList sx) = "list of length " ++ show (length sx)++-- | Utility function for parsing a pair of things.+--+-- >>> fromPair (isAtom "pachy") (asAtom return) (L [A "pachy", A "derm"])+-- Right ((), "derm")+-- >>> fromPair (isAtom "pachy") fromAtom (L [A "pachy"])+-- Left "Expected two-element list"+fromPair :: (WellFormedSExpr t -> Either String a)+ -> (WellFormedSExpr t -> Either String b)+ -> WellFormedSExpr t -> Either String (a, b)+fromPair pl pr (L [l, r]) = (,) <$> pl l <*> pr r+fromPair _ _ sx = Left ("fromPair: expected two-element list; found " ++ getShape sx)++-- | Utility function for parsing a list of things.+--+-- >>> fromList fromAtom (L [A "this", A "that", A "the-other"])+-- Right ["this","that","the-other"]+-- >>> fromList fromAtom (A "pachyderm")+-- Left "asList: expected proper list; found dotted list"+fromList :: (WellFormedSExpr t -> Either String a)+ -> WellFormedSExpr t -> Either String [a]+fromList p (L ss) = mapM p ss+fromList _ sx = Left ("fromList: expected list; found " ++ getShape sx)++-- | Utility function for parsing a single atom+--+-- >>> fromAtom (A "elephant")+-- Right "elephant"+-- >>> fromAtom (L [A "elephant"])+-- Left "fromAtom: expected atom; found list"+fromAtom :: WellFormedSExpr t -> Either String t+fromAtom (A a) = return a+fromAtom sx = Left ("fromAtom: expected atom; found " ++ getShape sx)++-- | Parses a two-element list using the provided function.+--+-- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"+-- >>> asPair go (L [A "pachy", A "derm"])+-- Right "pachyderm"+-- >>> asPair go (L [A "elephant"])+-- Left "asPair: expected two-element list; found list of length 1"+asPair :: ((WellFormedSExpr t, WellFormedSExpr t) -> Either String a)+ -> WellFormedSExpr t -> Either String a+asPair f (L [l, r]) = f (l, r)+asPair _ sx = Left ("asPair: expected two-element list; found " ++ getShape sx)++-- | Parse an arbitrary-length list using the provided function.+--+-- >>> let go xs = concat <$> mapM fromAtom xs+-- >>> asList go (L [A "el", A "eph", A "ant"])+-- Right "elephant"+-- >>> asList go (A "pachyderm")+-- Left "asList: expected list; found atom"+asList :: ([WellFormedSExpr t] -> Either String a)+ -> WellFormedSExpr t -> Either String a+asList f (L ls) = f ls+asList _ sx = Left ("asList: expected list; found " ++ getShape sx)++-- | Match a given literal atom, failing otherwise.+--+-- >>> isAtom "elephant" (A "elephant")+-- Right ()+-- >>> isAtom "elephant" (L [A "elephant"])+-- Left "isAtom: expected atom; found list"+isAtom :: Eq t => t -> WellFormedSExpr t -> Either String ()+isAtom s (A s')+ | s == s' = return ()+ | otherwise = Left "isAtom: failed to match atom"+isAtom _ sx = Left ("isAtom: expected atom; found " ++ getShape sx)++-- | Match an empty list, failing otherwise.+--+-- >>> isNil (L [])+-- Right ()+-- >>> isNil (A "elephant")+-- Left "isNil: expected nil; found atom"+isNil :: WellFormedSExpr t -> Either String ()+isNil Nil = return ()+isNil sx = Left ("isNil: expected nil; found " ++ getShape sx)++-- | Parse an atom using the provided function.+--+-- >>> import Data.Char (toUpper)+-- >>> asAtom (return . map toUpper) (A "elephant")+-- Right "ELEPHANT"+-- >>> asAtom (return . map toUpper) (L [])+-- Left "asAtom: expected atom; found list"+asAtom :: (t -> Either String a) -> WellFormedSExpr t -> Either String a+asAtom f (A s) = f s+asAtom _ sx = Left ("asAtom: expected atom; found " ++ getShape sx)++-- | Parse an assoc-list using the provided function.+--+-- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }+-- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }+-- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "trunk", A "one"] ])+-- Right "legs: four\ntrunk: one\n"+-- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "elephant"] ])+-- Left "asAssoc: expected pair; found list of length 1"+asAssoc :: ([(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a)+ -> WellFormedSExpr t -> Either String a+asAssoc f (L ss) = gatherPairs ss >>= f+ where gatherPairs (L [a, b] : ts) = (:) <$> pure (a, b) <*> gatherPairs ts+ gatherPairs [] = pure []+ gatherPairs (sx:_) = Left ("asAssoc: expected pair; found " ++ getShape sx)+asAssoc _ sx = Left ("asAssoc: expected list; found " ++ getShape sx)++-- | Run the parser on the first element of a Haskell list of "WellFormedSExpr" values,+-- failing if the list is empty. This is useful in conjunction with the `asList`+-- function.+car :: (WellFormedSExpr t -> Either String t')+ -> [WellFormedSExpr t] -> Either String t'+car f (x:_) = f x+car _ [] = Left "car: Taking car of zero-element list"++-- | Run the parser on all but the first element of a Haskell list of "WellFormedSExpr" values,+-- failing if the list is empty. This is useful in conjunction with the `asList`+-- function.+cdr :: ([WellFormedSExpr t] -> Either String t')+ -> [WellFormedSExpr t] -> Either String t'+cdr f (_:xs) = f xs+cdr _ [] = Left "cdr: Taking cdr of zero-element list"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Getty Ritter++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Getty Ritter nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ s-cargot.cabal view
@@ -0,0 +1,44 @@+name: s-cargot+version: 0.1.0.0+synopsis: A flexible, extensible s-expression library.+homepage: https://github.com/aisamanra/s-cargot+description: S-Cargot is a library for working with s-expressions in+ a modular and extensible way, opting for genericity and+ flexibility instead of speed. Instead of understanding+ one particular form of s-expression, the S-Cargot library+ exposes tools for parsing or emitting different kinds of+ s-expressions, including features not normally included+ in an s-expression library like reader macros or tight+ control over indentation in pretty-printing.+license: BSD3+license-file: LICENSE+author: Getty Ritter+maintainer: gettyritter@gmail.com+copyright: 2015 Getty Ritter+category: Data+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/aisamanra/s-cargot.git++library+ exposed-modules: Data.SCargot,+ Data.SCargot.Repr,+ Data.SCargot.Repr.Basic,+ Data.SCargot.Repr.Rich,+ Data.SCargot.Repr.WellFormed,+ Data.SCargot.Parse,+ Data.SCargot.Print,+ Data.SCargot.Comments,+ Data.SCargot.Common,+ Data.SCargot.Language.Basic,+ Data.SCargot.Language.HaskLike+ build-depends: base >=4.7 && <5,+ parsec >=3.1 && <4,+ text >=1.2 && <2,+ containers >=0.5 && <1+ default-language: Haskell2010+ default-extensions: CPP+ ghc-options: -Wall