packages feed

sexpresso (empty) → 1.0.0.2

raw patch · 18 files changed

+2167/−0 lines, 18 filesdep +basedep +containersdep +megaparsecsetup-changed

Dependencies added: base, containers, megaparsec, sexpresso, smallcheck, tasty, tasty-hunit, tasty-smallcheck, text

Files

+ ChangeLog.md view
@@ -0,0 +1,46 @@+# Changelog for S-expresso++Version 1.0.0.2+---------------++* Update Resolver+* Update synopsis++Version 1.0.0.1+---------------++* Add version bounds to the dependencies++Version 1.0.0.0+---------------++* Change type of SExprParser from `SExpParser m c b a` to `SExprParser m+  b a`. The `c` parameter is now an existential. ++* `SExprParser` is not a record anymore. So `pAtom`, `pSpace` and+  `pSpacingRule` are now functions and cannot be used in record+  syntax. The have been rename to `getAtom`, `getSpace` and+  `getSpacingRule`.++* The `pSTag` and `pETag` functions have been removed since `SExprParser`+  is defined using an existential.+  +* Documentation improvements.++Version 0.1.1.1+---------------++* Fix documentation error for the pattern :::++Version 0.1.1.0+---------------++* Add Scheme R5RS language++Version 0.1.0.0+--------------- ++* SExpr datatype+* Generic SExpr parser+* SExpr parser for character+* SExpr flat printer
+ LICENSE view
@@ -0,0 +1,13 @@+Zero-Clause BSD++Permission to use, copy, modify, and/or distribute this software for+any purpose with or without fee is hereby granted.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL+WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE+AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL+DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR+PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ README.md view
@@ -0,0 +1,174 @@+# S-expresso++S-expresso is a Haskell library designed to help you parse and print+data or source code encoded as an S-expression. It provides a very+flexible parser and (for now) a flat printer.++# What is an S-expression+Basically, an S-expression is a special form of tree structured+data. An S-expression object is either an atom or a list of atoms and other S-expressions.++This datatype is the definition of an S-expression for+S-expresso. ++~~~haskell+data SExpr b a = SList b [SExpr b a]+               | SAtom a+~~~++The parameter `a` allows you to specify the datatype of atoms and the+parameter `b` is usefull for keeping metadata about S-expression like+source position for example.++`SExpr` is not equivalent to `[a]` because the later cannot+distinguish between an atom `(SAtom _)` and a tree containing only one+atom `(SList _ [SAtom _])`. `SExpr` is also not equivalent to `Tree a`+from `Data.Tree` because the later cannot encode the empty tree+`(SList _ [])` and does not enforce that atoms are at the leaves.++## The Sexp type+If you are only interested by the atoms, you can use the type alias+`Sexp` that is a variant of the more general 'SExpr' data type with no+data for the 'SList' constructor.+~~~haskell+type Sexp a = SExpr () a+~~~++This type also comes with a bidirectional pattern synonym also named+`Sexp` for object of the form `SExpr () _`.+~~~+x = Sexp [A 3]                   <-> x = SList () [SAtom 3]+foo (Sexp xs)                    <-> foo (SList () xs)+foo (Sexp (Sexp ys : A x : xs))  <-> foo (SList () (SList () ys : SAtom x : xs))+~~~++## Pattern synonyms+S-expresso defines four pattern synonyms to ease your programming with+`SExpr`. The patterns `L` helps you match the `SList` constructor and only+its sublist, disregarding the `b` field. The pattern `:::` and `Nil` helps+you specify the shape of the sublist of an `SList` constructor and+finally the pattern `A` is a shorthand for `SAtom`.++Together they make working with `SExpr` a little easier.+~~~+a = A 3                      <-> a = SAtom 3+foo (A x)                    <-> foo (SAtom x)+foo (A x1 ::: A x2 ::: Nil)  <-> foo (SList _ [SAtom x1, SAtom x2])+foo (A x ::: L xs))          <-> foo (SList _ (SAtom x : xs))+foo (L ys ::: A x ::: L xs)) <-> foo (SList _ (SList _ ys : SAtom x : xs))+foo (L x)                    <-> foo (SList _ x)+~~~++Notice that you need to end the pattern `:::` with `Nil` for the empty+list or `L xs` for matching the remainder of the list. Indeed, if you write++~~~+foo (x ::: xs) = ...+~~~++this is equivalent to :++~~~+foo (SList b (x : rest)) = let xs = SList b rest+                           in ...+~~~++You can refer to the documentation of the `:::` constructor for more information.++# Parsing S-expressions+The parsing is based on+[megaparsec](http://hackage.haskell.org/package/megaparsec). S-expresso+allows you to customize the following :+* The parser for atoms+* The opening tag (usually "("), the closing tag (usually ")") and a+  possible dependency of the closing tag on the opening one.+* If some space is required or optional between any pair of atoms.+* How to parse space (ex: treat comments as whitespace)++The library offers amoung others the `decodeOne` and `decode`+functions. The former only reads one S-expression while the other+parses many S-expressions.  Both functions creates a megaparsec+parser from a `SExprParser` argument.++The `SExprParser` is the data type that defines how to read an+S-expression.  The easiest way to create a `SExprParser` is to use the+function `plainSExprParser` with your own custom atom parser. This+will create a parser where S-expression starts with "(", ends with ")"+and space is mandatory between atoms.++~~~haskell+Import Data.Void+Import qualified Data.Text as T+Import Text.Megaparsec+Import Text.Megaparsec.Char+Import qualified Text.Megaparser.Char.Lexer as L++atom = some letter++sexp = decode $ plainSExprParser atom++-- Returns (SList () [SAtom "hello", SAtom "world"])+ex1 = parse sexp "" "(hello world)"++-- Returns (SList () [SAtom "hello", SAtom "world", SList () [SAtom "bonjour"]])+ex2 = parse sexp "" "  (hello world(bonjour))  "++-- Returns SAtom "hola"+ex2 = parse sexp "" "hola"+~~~++## Customizing the SExprParser+S-expresso provides many functions to modify the behavior of the+parser. For example, you can use the functions `setTags`,+`setTagsFromList`, `setSpace` and `setSpacingRule` to modify the+behavior of the parser. Following on the preceding example:++~~~haskell+-- setTags+data MyType = List | Vector++listOrVector =+  let sTag = (char '(' >> return List) <|> (string "#(" >> return Vector)+      eTag = \t -> char ')' >> return t+      p = setTags sTag eTag $+          plainSExprParser atom+  in decode p++-- Returns (SList List [SList Vector [SAtom "a", SAtom "b"], SAtom "c"])+ex3 = parse listOrVector "" "(#(a b) c)"++-- setTagsFromList+listOrVector2 = decode $ +                setTagsFromList [("(",")",List),("#(",")",Vector)] $+                plainSExprParser atom+++-- Returns (SList List [SList Vector [SAtom "a", SAtom "b"], SAtom "c"])+ex4 = parse listOrVector2 "" "(#(a b) c)"++-- setSpace+withComments = decode $+               -- See megaparsec Space in Megaparsec.Char.Lexer+               setSpace (L.Space Space1 (skipLineComment ";") empty) $+               plainSExprParser atom++-- Returns (SList () [SAtom "hello", SList () [SAtom "bonjour"]])+ex5 = parse withComments "" "(hello ;world\n (bonjour))"++-- setSpacingRule+optionalSpace = decode $+                setSpacingRule spaceIsOptional $+                plainSExprParser (some letter <|> some digitChar)++-- Returns (SList () [SAtom "hello", SAtom "1234", SAtom "world"])+ex5 = parse optionalSpace "" "(hello1234world)"+~~~++You can also directly build a custom SExprParser with the constructor `SExprParser`.++## Adding Source Location+If you need the source position of the atoms and s-expression, the+function `withLocation` transforms an `SExprParser b a` into+`SExprParser (Located b) (Located a)`. The `Located` datatype is+defined+[here](https://github.com/archambaultv/sexpresso/blob/master/src/Data/SExpresso/Parse/Location.hs).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sexpresso.cabal view
@@ -0,0 +1,74 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d10313f25fa0bc844633d9e84210f3959d3915bbee2d0c767e121aa3ddd2bd5f++name:           sexpresso+version:        1.0.0.2+synopsis:       A flexible library for parsing and printing S-expression+description:    Please see the README on GitHub at <https://github.com/archambaultv/sexpresso#readme>+category:       Data+homepage:       https://github.com/archambaultv/sexpresso#readme+bug-reports:    https://github.com/archambaultv/sexpresso/issues+author:         Vincent Archambault-Bouffard+maintainer:     archambault.v@gmail.com+copyright:      Vincent Archambault-Bouffard+license:        OtherLicense+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/archambaultv/sexpresso++library+  exposed-modules:+      Data.SExpresso.Language.SchemeR5RS+      Data.SExpresso.Parse+      Data.SExpresso.Parse.Char+      Data.SExpresso.Parse.Generic+      Data.SExpresso.Parse.Location+      Data.SExpresso.Print+      Data.SExpresso.Print.Lazy+      Data.SExpresso.SExpr+  other-modules:+      Paths_sexpresso+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , containers >=0.5 && <0.7+    , megaparsec >=7.0 && <8.0+    , text >=0.2 && <1.3+  default-language: Haskell2010++test-suite sexpresso-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Parse_Unittests+      Print_Unittests+      SchemeR5RS_Unittests+      SExpr_Unittests+      Paths_sexpresso+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers >=0.5 && <0.7+    , megaparsec >=7.0 && <8.0+    , sexpresso+    , smallcheck >=1.0+    , tasty >=0.8+    , tasty-hunit >=0.10.0.1+    , tasty-smallcheck >=0.8+    , text >=0.2 && <1.3+  default-language: Haskell2010
+ src/Data/SExpresso/Language/SchemeR5RS.hs view
@@ -0,0 +1,618 @@+-- |+-- Module      :  Data.SExpresso.SExpr+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- Module for parsing the Scheme R5RS language.+--+-- Scheme R5RS s-expressions are parsed as @'SExpr' 'SExprType'+-- 'SchemeToken'@.  Such s-expressions can be converted into a Scheme+-- R5RS datum (see 'Datum') by the function 'sexpr2Datum'.+++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- Parsing library for some parts of the Scheme R5RS language+-- as defined in section 7 of the report+-- The library does parse tab and \r\n and whitespace+module Data.SExpresso.Language.SchemeR5RS (+  -- * SchemeToken and Datum related data types and functions +  SExprType(..),+  SchemeToken(..),+  tokenParser,+  sexpr,++  Datum(..),+  sexpr2Datum,++  -- * Scheme R5RS whitespace parsers+  whitespace,+  comment,+  interTokenSpace,+  interTokenSpace1,++  -- * Individual parser for each of the constructors of SchemeToken+  identifier,+  boolean,+  character,+  stringParser,+  quote,+  quasiquote,+  comma,+  commaAt,+  dot,++  -- ** Scheme Number+  --+  -- | Scheme R5RS numbers are quite exotic. They can have exactness+  -- prefix, radix prefix and the pound sign (#) can replace a+  -- digit. On top of that, you can define integer, rational, decimal+  -- and complex numbers of arbitrary precision. Decimal numbers can+  -- also have a suffix indicating the machine precision.+  --+  -- Since Haskell does not have native types to express this+  -- complexity, this module defines the 'SchemeNumber' data type to+  -- encode the parsed number. User of this module can then convert a+  -- 'SchemeNumber' object to a more appropriate data type according+  -- to their needs.+  SchemeNumber(..),+  Exactness(..),+  Complex(..),+  SReal(..),+  Sign(..),+  UInteger(..),+  Pounds,+  Precision(..),+  Suffix(..),+  number,+++  ) where++import Data.Maybe+import Data.Proxy+import Data.List+import qualified Data.Char as C+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as B+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as ML+import Data.SExpresso.SExpr+import Data.SExpresso.Parse++-- | The 'SchemeToken' data type defines the atoms of an Scheme R5RS+-- s-expression. An @'SExpr' 'SExprType' 'SchemeToken'@ object+-- containning the atoms 'TQuote', 'TQuasiquote', 'TComma', 'TCommaAt'+-- and 'TDot' need futher processing in order to get what the R5RS+-- report calls a datum. See also 'Datum'.+data SchemeToken =+  -- | A boolean.+  TBoolean Bool+  -- | A number. See 'SchemeNumber'.+  | TNumber SchemeNumber+  -- | A unicode character.+  | TChar Char+  -- | A string.+  | TString T.Text+  -- | A valid R5RS identifier.+  | TIdentifier T.Text+  -- | The quote (') symbol.+  | TQuote+  -- | The quasiquote (`) symbol.+  | TQuasiquote+  -- | The comma (,) symbol.+  | TComma+  -- | The comma at (,\@) symbol.+  | TCommaAt+  -- | The dot (.) symbol.+  | TDot+  deriving (Eq, Show)++-- | The 'tokenParser' parses a 'SchemeToken'+tokenParser :: (MonadParsec e s m, Token s ~ Char) => m SchemeToken+tokenParser = (boolean >>= return . TBoolean) <|>+              -- character must come before number+              (character >>= return . TChar) <|>+              (stringParser >>= return . TString) <|>+              (identifier >>= return . TIdentifier) <|>+              (quote >> return TQuote) <|>+              (quasiquote >> return TQuasiquote) <|>+              -- commaAt must come before comma+              (commaAt >> return TCommaAt) <|> +              (comma >> return TComma) <|>+              -- We must try number because it can conflict with the dot ex : .2 and (a . b)+              (try number >>= return . TNumber) <|>+              (dot >> return TDot)+              +++spacingRule :: SchemeToken -> SpacingRule+spacingRule (TString _) = SOptional+spacingRule TQuote = SOptional+spacingRule TQuasiquote  = SOptional+spacingRule TComma = SOptional+spacingRule TCommaAt = SOptional+spacingRule _ = SMandatory++-- | Scheme R5RS defines two types of s-expressions. Standard list+-- beginning with '(' and vector beginning with '#('. The 'SExprType'+-- data type indicates which one was parsed.+data SExprType =+  -- | A standard list+  STList+  -- | A vector+  | STVector+  deriving (Eq, Show)++-- | The 'sexpr' defines a 'SExprParser' to parse a Scheme R5RS+-- s-expression as an @'SExpr' 'SExprType' 'SchemeToken'@. If you also+-- want source position see the 'withLocation' function.+--+-- Space is optional before and after the following tokens:+--+-- * 'TString'+-- * 'TQuote'+-- * 'TQuasiquote'+-- * 'TComma'+-- * 'TCommaAt'+sexpr :: forall e s m . (MonadParsec e s m, Token s ~ Char) => SExprParser m SExprType SchemeToken+sexpr =+  let sTag = (single '(' >> return STList) <|> (chunk (tokensToChunk (Proxy :: Proxy s) "#(") >> return STVector)+      eTag = \t -> single ')' >> return t+  in SExprParser sTag eTag tokenParser interTokenSpace1 (mkSpacingRule spacingRule)++-- | The 'Datum' data type implements the Scheme R5RS definition of a Datum. See also 'sexpr2Datum'.+data Datum = DBoolean Bool+           | DNumber SchemeNumber+           | DChar Char+           | DString T.Text+           | DIdentifier T.Text+           | DList [Datum]+           | DDotList [Datum] Datum+           | DQuote Datum+           | DQuasiquote Datum+           | DComma Datum+           | DCommaAt Datum+           | DVector [Datum]+           deriving (Eq, Show)++-- | The 'sexpr2Datum' function takes a list of 'SchemeToken' and+-- returns a list of 'Datum'. In case of failure it will report an+-- error, hence the 'Either' data type in the signature.+--+-- As defined in the Scheme R5RS report, the 'TQuote', 'TQuasiquote',+-- 'TComma', 'TCommaAt' and 'TDot' tokens must be followed by another+-- token.+sexpr2Datum :: [SExpr SExprType SchemeToken] -> Either String [Datum]+sexpr2Datum [] = Right []+sexpr2Datum ((A (TBoolean x)) : xs) = (:) <$> pure (DBoolean x) <*> sexpr2Datum xs+sexpr2Datum ((A (TNumber x)) : xs) = (:) <$> pure (DNumber x) <*> sexpr2Datum xs+sexpr2Datum ((A (TChar x)) : xs) = (:) <$> pure (DChar x) <*> sexpr2Datum xs+sexpr2Datum ((A (TString x)) : xs) = (:) <$> pure (DString x) <*> sexpr2Datum xs+sexpr2Datum ((A (TIdentifier x)) : xs) = (:) <$> pure (DIdentifier x) <*> sexpr2Datum xs+sexpr2Datum ((A TQuote) : xs) = do+  xs' <- sexpr2Datum xs+  if null xs'+  then Left "Expecting a datum after the quote."+  else return $ DQuote (head xs') : tail xs'+sexpr2Datum ((A TQuasiquote) : xs) = do+  xs' <- sexpr2Datum xs+  if null xs'+  then Left "Expecting a datum after the quasiquote."+  else return $ DQuasiquote (head xs') : tail xs'+sexpr2Datum ((A TComma) : xs) = do+  xs' <- sexpr2Datum xs+  if null xs'+  then Left "Expecting a datum after the comma."+  else return $ DComma (head xs') : tail xs'+sexpr2Datum ((A TCommaAt) : xs) = do+  xs' <- sexpr2Datum xs+  if null xs'+  then Left "Expecting a datum after the quote."+  else return $ DCommaAt (head xs') : tail xs'+sexpr2Datum ((A TDot) : _) = Left "Unexpected dot"+sexpr2Datum ((SList STVector vs) : xs) = (:) <$> (sexpr2Datum vs >>= return . DVector) <*> sexpr2Datum xs+sexpr2Datum ((SList STList ls) : xs) = (:) <$> (listToken2Datum ls) <*> sexpr2Datum xs+  where listToken2Datum ys =+          let l = length ys+          in if l < 3+             then sexpr2Datum ys >>= return . DList+             else let penultimate = head $ drop (l - 2) ys+                  in case penultimate of+                       (A TDot) ->+                         let last' = head $ drop (l - 1) ys+                             tokens' = take (l - 2) ys+                         in do+                           lastD <- sexpr2Datum [last']+                           tokensD <- sexpr2Datum tokens'+                           return $ DDotList tokensD (head lastD) +                       _ -> sexpr2Datum ys >>= return . DList+++------------------------- Whitespace and comments -------------------------+-- | The 'whitespace' parser  parses one space, tab or end of line (\\n and \\r\\n).+whitespace :: (MonadParsec e s m, Token s ~ Char) => m ()+whitespace = (char ' ' >> return ()) <|>+             (char '\t' >> return ()) <|>+             (eol >> return ())++-- | The 'comment' parser parses a semi-colon (;) character and+-- everything until the end of line included.+comment :: (MonadParsec e s m, Token s ~ Char) => m ()+comment = char ';' >>+          takeWhileP Nothing (\c -> c /= '\n' && c /= '\r') >>+          ((eol >> return ()) <|> eof)++atmosphere :: (MonadParsec e s m, Token s ~ Char) => m ()+atmosphere = whitespace <|> comment++-- | The 'interTokenSpace' parser parses zero or more whitespace or comment.+interTokenSpace :: (MonadParsec e s m, Token s ~ Char) => m ()+interTokenSpace = many atmosphere >> return ()++-- | The 'interTokenSpace1' parser parses one or more whitespace or comment.+interTokenSpace1 :: (MonadParsec e s m, Token s ~ Char) => m ()+interTokenSpace1 = some atmosphere >> return ()++------------------------- Identifier -------------------------++-- | The 'identifier' parser parses a Scheme R5RS identifier.+identifier :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m T.Text+identifier = standardIdentifier <|> peculiarIdentifier+  where standardIdentifier = do+          i <- oneOf initialList+          is <- takeWhileP Nothing (\c -> c `elem` subsequentList)+          return $ T.pack $ (i : chunkToTokens (Proxy :: Proxy s) is)++initialList :: String+initialList = ['a'..'z'] ++ ['A'..'Z'] ++ "!$%&*/:<=>?^_~"++subsequentList :: String+subsequentList = initialList ++ ['0'..'9'] ++ "+-.@"++peculiarIdentifier :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m T.Text+peculiarIdentifier = (single '+' >> return "+") <|>+                     (single '-' >> return "-") <|>+                     (chunk (tokensToChunk (Proxy :: Proxy s) "...") >> return "...")++------------------------- Booleans -------------------------+-- | The 'boolean' parser parses a Scheme R5RS boolean (\#t or \#f).+boolean :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m Bool+boolean = (chunk (tokensToChunk (Proxy :: Proxy s) "#t") >> return True) <|>+          (chunk (tokensToChunk (Proxy :: Proxy s) "#f") >> return False)+++------------------------- Character -------------------------+-- | The 'character' parser parses a Scheme R5RS character.+character :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m Char+character = do+  _ <- chunk (tokensToChunk (Proxy :: Proxy s) "#\\")+  (chunk (tokensToChunk (Proxy :: Proxy s) "newline") >> return '\n') <|>+   (chunk (tokensToChunk (Proxy :: Proxy s) "space") >> return ' ') <|>+   anySingle++------------------------- String -------------------------+-- | The 'stringParser' parser parses a Scheme R5RS character.+stringParser :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m T.Text+stringParser = do+  _ <- char '"'+  xs <- consume+  return $ L.toStrict $ B.toLazyText xs++  where consume :: (MonadParsec e s m, Token s ~ Char) => m B.Builder+        consume = do+          x <- takeWhileP Nothing (\c -> c /= '\\' && c /= '"')+          c <- char '\\' <|> char '"'+          let xB = B.fromString $ chunkToTokens (Proxy :: Proxy s) x+          case c of+            '"' -> return $ xB+            _ -> do+               c1 <- char '\\' <|> char '"'+               x2 <- consume+               return $ xB <> B.fromString [c1] <> x2+++------------------------- Numbers -------------------------+data Radix = R2 | R8 | R10 | R16+           deriving (Eq, Show)++-- | A Scheme R5RS number is either exact or inexact. The paragraph+-- 6.4.2 from the R5RS report should clarify the meaning of exact and+-- inexact :+--+-- \"\"\"A numerical constant may be specified to be either+-- exact or inexact by a prefix.  The prefixes are \#e for exact, and \#i+-- for inexact.  An exactness prefix may appear before or after any+-- radix prefix that is used.  If the written representation of a+-- number has no exactness prefix, the constant may be either inexact+-- or exact.  It is inexact if it contains a decimal point, an+-- exponent, or a \“#\” character in the place of a digit, otherwise it+-- is exact.\"\"\"+data Exactness = Exact | Inexact+               deriving (Eq, Show)++-- | The 'Sign' datatype indicates if a number is positive ('Plus') or negative ('Minus')+data Sign = Plus | Minus+          deriving (Eq, Show)++-- | A Scheme R5RS number can have many # signs at the end. This type alias+-- indicates the number of # signs parsed.+type Pounds = Integer++-- | A Scheme R5RS unsigned integer can be written in three ways.+--+-- * With digits only+-- * With digits and # signs+-- * With only # signs in some special context.+data UInteger =+  -- | Integer made only of digits+  UInteger Integer+  -- | Integer made of digits and #. The first argument is the number+  -- that was parsed and the second the number of # signs. For+  -- example, 123## is represented as @UIntPounds 123 2@. Do not take+  -- the first argument as a good approximation of the number. It+  -- needs to be shifted by the number of pounds.+  | UIntPounds Integer Pounds+  -- | Integer made only of #. It can only appear as the third argument in numbers of the form @'SDecimal' _ _ _ _@.+  | UPounds Pounds+  deriving (Eq, Show)++hasPounds :: UInteger -> Bool+hasPounds (UInteger _) = False+hasPounds _ = True++isInexactI :: UInteger -> Bool+isInexactI = hasPounds++-- | Scheme R5RS defines 5 types of machine precision for a decimal+-- number. The machine precision is specified in the suffix (see+-- 'Suffix').+data Precision =+  -- | Suffix starting with e.+  PDefault |+  -- | Suffix starting with s.+  PShort |+  -- | Suffix starting with f.+  PSingle |+  -- | Suffix starting with d.+  PDouble |+  -- | Suffix starting with l.+  PLong+  deriving (Eq, Show)++-- | The 'Suffix' data type represents the suffix for a Scheme R5RS+-- decimal number. It is a based 10 exponent.+data Suffix = Suffix Precision Sign Integer+            deriving (Eq, Show)++-- | The 'SReal' data type represents a Scheme R5RS real number.+data SReal =+  -- | A signed integer.+  SInteger Sign UInteger+  -- | A signed rational. The first number is the numerator and the+  -- second one the denominator.+  | SRational Sign UInteger UInteger+  -- | A signed decimal number. The first number appears before the+  -- dot, the second one after the dot.+  | SDecimal Sign UInteger UInteger (Maybe Suffix)+  deriving (Eq, Show)++isInexactR :: SReal -> Bool+isInexactR (SInteger _ i) = isInexactI i+isInexactR (SRational _ i1 i2) = isInexactI i1 || isInexactI i2+isInexactR (SDecimal _ _ _ _) = True++-- | The 'Complex' data type represents a Scheme R5RS complex number.+data Complex =+  -- | A real number.+  CReal SReal+  -- | A complex number in angular notation.+  | CAngle SReal SReal+  -- | A complex number in absolute notation.+  | CAbsolute SReal SReal+  deriving (Eq, Show)++isInexact :: Complex -> Bool+isInexact (CReal s) = isInexactR s+isInexact (CAngle s1 s2) = isInexactR s1 || isInexactR s2+isInexact (CAbsolute s1 s2) = isInexactR s1 || isInexactR s2++-- | A Scheme R5RS number is an exact or inexact complex number.+data SchemeNumber = SchemeNumber Exactness Complex+                  deriving (Eq, Show)++-- | The 'number' parser parses a Scheme R5RS number.+number :: (MonadParsec e s m, Token s ~ Char) => m SchemeNumber+number = do+  (r, e) <- prefix+  c <- complex (fromMaybe R10 r)+  let e' = fromMaybe (if isInexact c then Inexact else Exact) e+  return $ SchemeNumber e'  c+ +complex :: forall e s m . (MonadParsec e s m, Token s ~ Char) => Radix -> m Complex+complex r = do+  ms <- optional sign+  case ms of+    Nothing -> complex' Plus+    Just s -> i s <|> complex' s++  where+    -- Parser for +i and -i+    i s = char 'i' >> (return $ CAbsolute (SInteger Plus (UInteger 0)) (SInteger s (UInteger 1)))++    -- Parser for complex except +i and -i+    complex' sr = do+      -- First parse a number+      n1 <- ureal r sr+      -- Check if the number is followed by any of these characters+      c <- optional (char '@' <|> char '+' <|> char '-' <|> char 'i')+      case c of+          -- Plain real number+          Nothing -> return $ CReal n1+          -- Complex angular number+          Just '@' -> do+            n2 <- real r+            return $ CAngle n1 n2+          -- Pure imaginary number+          Just 'i' -> return $ CAbsolute (SInteger Plus (UInteger 0)) n1+          -- Real +/- Imaginary number+          Just '+' -> imaginaryPart n1 Plus+          Just _ -> imaginaryPart n1 Minus+  +    imaginaryPart realN si = do+      u <- optional (ureal r si)+      _ <- char 'i'+      case u of+        Nothing -> return $ CAbsolute realN (SInteger si (UInteger 1))+        Just n2 -> return $ CAbsolute realN n2++real :: (MonadParsec e s m, Token s ~ Char) => Radix -> m SReal+real r = do+  s <- option Plus sign+  ureal r s++ureal :: forall e s m . (MonadParsec e s m, Token s ~ Char) => Radix -> Sign -> m SReal+ureal r s = dotN <|> ureal'++  where dotN =  do+          _ <- char '.'+          if r /= R10+          then fail "Numbers containing decimal point must be in decimal radix"+          else do+             n <- uinteger R10+             sf <- optional suffix+             return $ SDecimal s (UInteger 0) n sf++        ureal' = do+          -- First parse an integer+          u1 <- uinteger r+          -- Check if the integer is followed by these characters+          mc <- optional (char '/' <|> char '.')+          case mc of+            -- Integer with or without suffix+            Nothing -> plainInteger u1+            -- Rational+            Just '/' -> rational u1+            -- Decimal+            Just _ -> decimal u1++        plainInteger u1 = do+            sf <- optional suffix+            case sf of+              Just _ -> return $ SDecimal s u1 (UInteger 0) sf+              Nothing -> return $ SInteger s u1+        +        rational u1 = do+          u2 <- uinteger r+          return $ SRational s u1 u2++        decimal u1 = do+          if r /= R10+          then fail "Numbers containing decimal point must be in decimal radix"+          else do+             -- If u1 has # character, only other # are+             -- allowed. Otherwise a number may be present+             n <- if hasPounds u1 then return Nothing else optional (udigit R10) :: m (Maybe Integer)+             pounds <- takeWhileP Nothing (== '#')+             sf <- optional suffix+             let nbPounds = toInteger $ chunkLength (Proxy :: Proxy s) pounds+             let u2 = case (hasPounds u1, nbPounds, n) of+                         (True, p, _) -> UPounds p+                         (False, 0, Nothing) -> UInteger 0+                         (False, 0, (Just x)) -> UInteger x+                         (False, p, Nothing) -> UPounds p+                         (False, p, (Just x)) -> UIntPounds x p+             return $ SDecimal s u1 u2 sf++uinteger :: forall e s m . (MonadParsec e s m, Token s ~ Char) => Radix -> m UInteger+uinteger r = do+  n <- udigit r+  pounds <- takeWhileP Nothing (== '#')+  let nbPounds = toInteger $ chunkLength (Proxy :: Proxy s) pounds+  if nbPounds <= 0+  then return $ UInteger n+  else return $ UIntPounds n nbPounds+  ++prefix :: (MonadParsec e s m, Token s ~ Char) => m (Maybe Radix, Maybe Exactness)+prefix = do+  x <- optional $ char '#'+  case x of+    Nothing -> return (Nothing, Nothing)+    _ -> do+      c <- char 'i' <|> char 'e' <|> char 'b' <|>+           char 'o' <|> char 'd' <|> char 'x'+      case c of+        'i' -> optional radix >>= \r -> return (r, Just Inexact)+        'e' -> optional radix >>= \r -> return (r, Just Exact)+        'b' -> optional exactness >>= \e -> return (Just R2, e)+        'o' -> optional exactness >>= \e -> return (Just R8, e)+        'd' -> optional exactness >>= \e -> return (Just R10, e)+        _ -> optional exactness >>= \e -> return (Just R16, e)++exactness :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m Exactness+exactness = (chunk (tokensToChunk (Proxy :: Proxy s) "#e") >> return Exact) <|>+            (chunk (tokensToChunk (Proxy :: Proxy s) "#i") >> return Inexact)+  +radix :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m  Radix+radix =+  (chunk (tokensToChunk (Proxy :: Proxy s) "#b") >> return R2) <|>+  (chunk (tokensToChunk (Proxy :: Proxy s) "#o") >> return R8) <|>+  (chunk (tokensToChunk (Proxy :: Proxy s) "#d") >> return R10) <|>+  (chunk (tokensToChunk (Proxy :: Proxy s) "#x") >> return R16)+  +udigit :: forall e s m a . (MonadParsec e s m, Token s ~ Char, Integral a) => Radix -> m a+udigit r = do+  case r of+    R2 -> ML.binary+    R8 -> ML.octal+    R10 -> ML.decimal+    R16 -> hexadecimal -- ML.hexadecimal also parses uppercase "ABCDEF"+  where hexadecimal = mkNum+                      <$> takeWhile1P Nothing (\c -> c `elem` ("0123456789abcdef" :: String))+                      <?> "hexadecimal integer"+                      +        mkNum    = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+        step a c = a * 16 + fromIntegral (C.digitToInt c)++sign :: (MonadParsec e s m, Token s ~ Char) => m  Sign+sign = (char '-' >> return Minus) <|> (char '+' >> return Plus)++suffix :: (MonadParsec e s m, Token s ~ Char) => m Suffix+suffix = do+  p <- (char 'e' >> return PDefault)  <|>+       (char 's' >> return PShort)  <|>+       (char 'f' >> return PSingle) <|>+       (char 'd' >> return PDouble) <|>+       (char 'l' >> return PLong)+  s <- option Plus sign+  n <- udigit R10+  return $ Suffix p s n++------------------------- Other tokens -------------------------+-- | The 'quote' parser parses a quote character (').+quote :: (MonadParsec e s m, Token s ~ Char) => m Char+quote = char '\''++-- | The 'quasiquote' parser parses a quasiquote character (`).+quasiquote :: (MonadParsec e s m, Token s ~ Char) => m Char+quasiquote = char '`'++-- | The 'comma' parser parses a comma (,).+comma :: (MonadParsec e s m, Token s ~ Char) => m Char+comma = char ','++-- | The 'commaAt' parser parses a comma followed by \@ (,\@).+commaAt :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m T.Text+commaAt = chunk (tokensToChunk (Proxy :: Proxy s) ",@") >> return ",@"++-- | The 'dot' parser parses a single dot character (.).+dot :: (MonadParsec e s m, Token s ~ Char) => m Char+dot = char '.'
+ src/Data/SExpresso/Parse.hs view
@@ -0,0 +1,23 @@+-- |+-- Module      :  Data.SExpresso.Parse+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- This module re-exports everything from+-- "Data.SExpresso.Parse.Generic", "Data.SExpresso.Parse.Char" and+-- "Data.SExpresso.Parse.Location".++module Data.SExpresso.Parse+  (+    module Data.SExpresso.Parse.Generic,+    module Data.SExpresso.Parse.Char,+    module Data.SExpresso.Parse.Location+    )+  where++import Data.SExpresso.Parse.Generic+import Data.SExpresso.Parse.Location+import Data.SExpresso.Parse.Char
+ src/Data/SExpresso/Parse/Char.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      :  Data.SExpresso.Parse.Char+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- The module "Data.SExpresso.Parse" re-exports the functions of this+-- module.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Data.SExpresso.Parse.Char+  (+    plainSExprParser+   )+  where++import Text.Megaparsec+import Text.Megaparsec.Char+import Data.SExpresso.Parse.Generic+++-- | The function 'plainSExprParser' accepts a parser for atoms and+-- returns a 'SExprParser' for a stream of 'Char' with the following+-- properties :+--+--  * The opening tag is (.+--  * The closing tag is ).+--  * The space parser is 'space1'.+--  * Space is always mandatory between atoms.+plainSExprParser :: (MonadParsec e s m, Token s ~ Char) =>+                    m a -> SExprParser m () a+plainSExprParser p = SExprParser+                     (char '(' >> return ())+                     (\_ -> char ')' >> return ())+                     p+                     space1+                     spaceIsMandatory
+ src/Data/SExpresso/Parse/Generic.hs view
@@ -0,0 +1,309 @@+-- |+-- Module      :  Data.SExpresso.Parse.Generic+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- This module includes everything you need to write a parser for+-- S-expression ('SExpr'). It is based on the "Text.Megaparsec"+-- library and parsers can be defined for any kind of ('MonadParsec' e+-- s m) instance. This is quite generic, if you are working with+-- streams of 'Char', we suggest you also import+-- "Data.SExpresso.Parse.Char" or simply "Data.SExpresso.Parse" which+-- re-exports everything.+--+-- You can customize your 'SExpr' parser by specifying the following:+--+--   * The parser for atoms+--+--   * The opening tag, the closing tag, and a possible dependency of+--     the closing tag on the opening one.+--+--   * If some space is required or optional between any pair of+--     atoms.+--+--   * How to parse space (ex: treat comments as whitespace)++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}++module Data.SExpresso.Parse.Generic+  (+    SExprParser(..),+    +    getAtom,+    getSpace,+    getSpacingRule,++    setTags,+    setTagsFromList,+    setTagsFromMap,+    setSpace,+    setSpacingRule,+    setAtom,++    SpacingRule(..),+    spaceIsMandatory,+    spaceIsOptional,+    mkSpacingRule,+    +    withLocation,++    parseSExprList,+    parseSExpr,+    decodeOne,+    decode+   )+  where++import Data.Maybe+import qualified Data.Map as M+import Control.Applicative+import Text.Megaparsec+import Data.SExpresso.SExpr+import Data.SExpresso.Parse.Location++-- | The 'SpacingRule' datatype is used to indicate if space is optional or mandatory between two consecutive @'SAtom' _@.+data SpacingRule =+  -- | Space is mandatory+  SMandatory+  -- | Space is optional+  | SOptional+   deriving (Show, Eq)++-- | The @'SExprParser' m b a@ datatype defines how to parse an+-- @'SExpr' b a@. Most parsing functions require the underlying monad+-- @m@ to be an instance of ('MonadParsec' e s m).++data SExprParser m b a+  -- | The @c@ parameter in the first two arguments is the type of the+  -- relation between the opening tag and the closing one.+  = forall c. SExprParser+  (m c) -- ^ The parser for the opening tag. Returns an object of an+        -- arbitrary type @c@ that will be used to create the closing+        -- tag parser.+  (c -> m b) -- ^ A function that takes the object returned by the+             -- opening tag parser and provide a parser for the+             -- closing tag.+  (m a) -- ^ The parser for atoms+  (m ()) -- ^ A parser for space tokens which does not accept empty+         -- input (e.g. 'Text.Megaparsec.Char.space1')+  (a -> a -> SpacingRule) -- ^ A function to tell if two consecutive+                          -- atoms must be separated by space or+                          -- not. See also 'mkSpacingRule' and+                          -- 'setSpacingRule'++-- | The 'getSpace' function returns the parser for whitespace of an 'SExprParser' object.+getSpace :: SExprParser m b a -> m ()+getSpace (SExprParser _ _ _ sp _) = sp++-- | The 'getSpacingRule' function returns spacing rule function of an 'SExprParser' object.+getSpacingRule :: SExprParser m b a -> (a -> a -> SpacingRule)+getSpacingRule (SExprParser _ _ _ _ sr) = sr++-- | The 'getAtom' function returns the parser for atoms of an 'SExprParser' object.+getAtom :: SExprParser m b a -> m a+getAtom (SExprParser _ _ a _ _) = a++-- | The 'withLocation' function adds source location to a @'SExprParser'@. See also 'Location'.+withLocation :: (MonadParsec e s m) => SExprParser m b a -> SExprParser m (Located b) (Located a)+withLocation (SExprParser pSTag pETag atom sp sr) =+  let s = do+        pos <- getSourcePos+        c <- pSTag+        return (pos, c)+      e = \(pos, c) -> do+        b <- pETag c+        pos2 <- getSourcePos+        return $ At (Span pos pos2) b+  in SExprParser s e (located atom) sp (\(At _ a1) (At _ a2) -> sr a1 a2)++-- | The 'setAtom' function updates a parser with a new parser for atoms and and new spacing rule function.+setAtom :: m a -> (a -> a -> SpacingRule) -> SExprParser m b a' -> SExprParser m b a+setAtom a sr (SExprParser pSTag pETag _ sp _) = SExprParser pSTag pETag a sp sr++-- | The 'setTags' function updates a parser with a new parser for the opening and closing tags.+setTags :: m c -> (c -> m b) -> SExprParser m b' a -> SExprParser m b a+setTags s e (SExprParser _ _ a sp sr) = SExprParser s e a sp sr++-- | The 'setTagsFromList' function helps you build the opening and+-- closing parsers from a list of triplets. Each triplet specifies a+-- stream of tokens to parse as the opening tag, a stream of tokens to+-- parse at the closing tag and what to return when this pair is+-- encountered. The 'setTagsFromList' can handle multiple triplets+-- with the same opening tags. See also 'setTagsFromMap'.+--+-- The example e1 parses "()" as @'SList' () []@.+--+-- > e1 = setTagsFromList [("(", ")", ()] p+--+-- The example e2 parses both "()" and "[]" as @'SList' () []@ but does+-- not parse "(]" or "[)"+--+-- > e2 = setTagsFromList [("(", ")", ()), ("[", "]", ())] p +--+-- The example e3 parses "()" as @'SList' List []@ and "#()" as+-- @'SList' Vector []@, but does not parse "(]" or "[)"+--+-- > e3 = setTagsFromList [("(", ")", List), ("#(",")",Vector)] p+--+-- The example e4 parses "()" as @'SList' ')' []@ and "(]" as+-- @'SList' ']' []@, but does not parse "])"+--+-- > e4 = setTagsFromList [("(", ")", ')'), ("(", "]", ']')] p +setTagsFromList ::  (MonadParsec e s m) =>+                    [(Tokens s, Tokens s, b)] -> SExprParser m b' a -> SExprParser m b a+setTagsFromList l p =+  let m = M.fromListWith (++) $ map (\(s,e,b) -> (s, [(e,b)])) l+  in setTagsFromMap m p++-- | The 'setTagsFromMap' function helps you build the opening and+-- closing parsers from a map. Each key specifies a stream of tokens to+-- parse as the opening tag and the value of the map specifies one or+-- more streams of tokens to parse at the closing tag and what to+-- return when this pair is encountered. See also 'setTagsFromList'.+--+-- The example e1 parses "()" as @'SList' () []@.+--+-- > e1 = setTagsFromList $ M.fromList [("(", [")", ()]] p+--+-- The example e2 parses both "()" and "[]" as @'SList' () []@ but does+-- not parse "(]" or "[)"+--+-- > e2 = setTagsFromList $ M.fromList [("(", [")", ()]), ("[", ["]", ()])] p +--+-- The example e3 parses "()" as @'SList' List []@ and "#()" as+-- @'SList' Vector []@, but does not parse "(]" or "[)"+--+-- > e3 = setTagsFromList $ M.fromList [("(", [")", List]), ("#(", [")",Vector])] p+--+-- The example e4 parses "()" as @'SList' ')' []@ and "(]" as+-- @'SList' ']' []@, but does not parse "])"+--+-- > e4 = setTagsFromList $ M.fromList [("(", [(")", ')'), ("]", ']')])] p +setTagsFromMap :: (MonadParsec e s m) =>+                  M.Map (Tokens s) [(Tokens s, b)] -> SExprParser m b' a -> SExprParser m b a+setTagsFromMap m p =+  let l = M.toList m++      choose [] = empty+      choose ((s, eb) : ts) = (chunk s >> return eb) <|> choose ts+      +      stag = choose l+      +      etag = \xs -> choice $ map (\(e, b) -> chunk e >> return b) xs+  in setTags stag etag p++-- | The 'spaceIsMandatory' function is a spacing rule where space is always mandatory. See also 'getSpacingRule'.+spaceIsMandatory :: a -> a -> SpacingRule+spaceIsMandatory = \_ _ -> SMandatory++-- | The 'spaceIsOptional' function is a spacing rule where space is always optional. See also 'getSpacingRule'.+spaceIsOptional :: a -> a -> SpacingRule+spaceIsOptional = \_ _ -> SOptional++-- | The 'setSpacingRule' function modifies a 'SExprParser' by setting+-- the function to tell if two consecutive atoms must be separated by+-- space or not. See also 'mkSpacingRule'.+setSpacingRule :: (a -> a -> SpacingRule) -> SExprParser m b a -> SExprParser m b a+setSpacingRule r p@(SExprParser pSTag pETag _ _ _) = SExprParser pSTag pETag (getAtom p) (getSpace p) r++-- | The 'mkSpacingRule' function is a helper to create a valid+-- spacing rule function for 'SExprParser' when some atoms have the+-- same 'SpacingRule' both before and after no matter what the other+-- atom is. It takes as argument a function @f@ that takes a single+-- atom and returns the 'SpacingRule' that applies both before and+-- after this atom.+--+-- For example, to create a spacing rule where space is optional both+-- before and after the fictitious @MyString@ token:+--+-- > s (MyString _) = SOptional+-- > s _ = Mandatory+-- > spacingRule = mkSpacingRule s+--+-- The above is equivalent to :+--+-- > spacingRule (MyString _) _ = SOptional+-- > spacingRule _ (MyString _) = SOptional+-- > spacingRule _ _ = SMandatory++mkSpacingRule :: (a -> SpacingRule) -> (a -> a -> SpacingRule)+mkSpacingRule f = \a1 a2 -> case f a1 of+                              SOptional -> SOptional+                              SMandatory -> f a2++-- | The 'setSpace' function modifies a 'SExprParser' by setting the+-- parser to parse whitespace. The parser for whitespace must not+-- accept the empty input (e.g. 'Text.Megaparsec.Char.space1')+setSpace :: m () -> SExprParser m b a -> SExprParser m b a+setSpace sp (SExprParser s e a _ sr) = SExprParser s e a sp sr++-- Tells if the space (or absence of) between two atoms is valid or not +spaceIsOK :: (a -> a -> SpacingRule) -> (SExpr b a) -> (SExpr b a) -> Bool -> Bool+spaceIsOK getSpacingRule' sexp1 sexp2 spaceInBetween =+  case (sexp1, sexp2, spaceInBetween) of+    (_, _, True) -> True+    (SList _ _, _, _) -> True+    (_, SList _ _, _) -> True+    (SAtom a1, SAtom a2, _) -> getSpacingRule' a1 a2 == SOptional++sepEndBy' :: (MonadParsec e s m) => m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]+sepEndBy' p sep f = sepEndBy1' p sep f <|> pure []++sepEndBy1' :: (MonadParsec e s m) => m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]+sepEndBy1' p sep f = do+  x <- p+  xs <- parseContent x+  return $ x : xs++  where parseContent a1 = do+          s <- maybe False (const True) <$> optional sep+          mpos <- if not s then Just <$> getSourcePos else return Nothing +          mx <- optional p+          case mx of+            Nothing -> return []+            Just a2 ->+              if spaceIsOK f a1 a2 s+              then do+                xs <- parseContent a2+                return $ a2 : xs+              else fail ("The previous two atoms are not separated by space.\n" +++                         "A space was expected at " ++ sourcePosPretty (fromJust mpos))++-- | The 'parseSExprList' function return a parser for parsing S-expression of the form @'SList' _ _@.+parseSExprList :: (MonadParsec e s m) =>+                SExprParser m b a -> m (SExpr b a)+parseSExprList def@(SExprParser pSTag pETag _ sp sr)  = do+          c <- pSTag+          _ <- optional sp+          xs <- sepEndBy' (parseSExpr def) sp sr+          b <- pETag c+          return $ SList b xs++-- | The 'parseSExpr' function return a parser for parsing+-- S-expression ('SExpr'), that is either an atom (@'SAtom' _@) or a+-- list @'SList' _ _@. See also 'decodeOne' and 'decode'.+parseSExpr :: (MonadParsec e s m) =>+              SExprParser m b a -> m (SExpr b a)+parseSExpr def = (getAtom def >>= return . SAtom) <|> (parseSExprList def)++-- | The 'decodeOne' function return a parser for parsing a file+-- containing only one S-expression ('SExpr'). It can parse extra+-- whitespace at the beginning and at the end of the file. See also+-- 'parseSExpr' and 'decode'.+decodeOne :: (MonadParsec e s m) => SExprParser m b a -> m (SExpr b a)+decodeOne def =+  let ws = getSpace def+  in optional ws *> parseSExpr def <* (optional ws >> eof)++-- | The 'decode' function return a parser for parsing a file+-- containing many S-expression ('SExpr'). It can parse extra+-- whitespace at the beginning and at the end of the file. See also+-- 'parseSExpr' and 'decodeOne'.+decode :: (MonadParsec e s m) => SExprParser m b a -> m [SExpr b a]+decode def =+  let ws = getSpace def+  in optional ws *> sepEndBy' (parseSExpr def) ws (getSpacingRule def) <* eof
+ src/Data/SExpresso/Parse/Location.hs view
@@ -0,0 +1,38 @@+-- |+-- Module      :  Data.SExpresso.Parse.Location+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- The module "Data.SExpresso.Parse" re-exports the functions and+-- datatypes of this module.++module Data.SExpresso.Parse.Location+  (+    Location(..),+    Located(..),+    located+   )+  where++import Text.Megaparsec++-- Taken from https://www.reddit.com/r/haskell/comments/4x22f9/labelling_ast_nodes_with_locations/d6cmdy9/++-- | The 'Location' datatype represents a source span +data Location = Span SourcePos SourcePos+              deriving (Eq, Ord, Show)++-- | The 'Located' datatype adds a source span to the type @a@+data Located a = At Location a+               deriving (Eq, Ord, Show)++-- | The 'located' function adds a source span to a parser.+located :: (MonadParsec e s m) => m a -> m (Located a)+located parser = do+  begin <- getSourcePos+  result <- parser+  end <- getSourcePos+  return $ At (Span begin end) result
+ src/Data/SExpresso/Print.hs view
@@ -0,0 +1,25 @@+-- |+-- Module      :  Data.SExpresso.Print+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- Printing 'SExpr' as 'Data.Text'. To print as lazy text+-- ("Data.Text.Lazy") see "Data.Sexpresso.Print.Lazy"++module Data.SExpresso.Print (+  PL.SExprPrinter(..),+  PL.mkPrinter,+  flatPrint+  ) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import Data.SExpresso.SExpr+import qualified Data.SExpresso.Print.Lazy as PL++-- | Prints an 'SExpr' on a single line+flatPrint :: PL.SExprPrinter b a -> SExpr b a -> T.Text+flatPrint p s = L.toStrict $ PL.flatPrint p s
+ src/Data/SExpresso/Print/Lazy.hs view
@@ -0,0 +1,52 @@+-- |+-- Module      :  Data.SExpresso.Print.Lazy+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- Printing 'SExpr' as 'Data.Text.Lazy'. To print as strict text+-- ("Data.Text") see "Data.Sexpresso.Print"++{-# LANGUAGE OverloadedStrings #-}++module Data.SExpresso.Print.Lazy (+  SExprPrinter(..),+  mkPrinter,+  flatPrint,+  flatPrintBuilder+  ) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as B+import Data.SExpresso.SExpr++-- | The 'SExprPrinter' defines how to print an 'SExpr'. +data SExprPrinter b a = SExprParser {+  -- | The opening and closing tags based on the content of the 'SList'+  printTags :: b -> [SExpr b a] -> (T.Text, T.Text),+  -- | How to print an atom+  printAtom :: a -> T.Text+  }++-- | An 'SExprPrinter' with the opening tag defined as '(' and the+-- closing tag defined as ')'+mkPrinter :: (a -> T.Text) -> SExprPrinter b a+mkPrinter p = SExprParser (\_ _ -> ("(", ")")) p++-- | Prints an 'SExpr' on a single line. Returns a 'B.Builder' instead of a lazy text 'L.Text'+flatPrintBuilder :: SExprPrinter b a -> SExpr b a -> B.Builder+flatPrintBuilder p (SAtom a) = B.fromText $ printAtom p a+flatPrintBuilder p (SList b xs) =+  let (sTag, eTag) = printTags p b xs+  in B.fromText sTag <> flatPrintList xs <> B.fromText eTag++  where flatPrintList [] = B.fromText ""+        flatPrintList [x] = flatPrintBuilder p x+        flatPrintList (y : ys) = flatPrintBuilder p y <> B.fromText " " <> flatPrintList ys++-- | Prints an 'SExpr' on a single line+flatPrint :: SExprPrinter b a -> SExpr b a -> L.Text+flatPrint p s = B.toLazyText $ flatPrintBuilder p s
+ src/Data/SExpresso/SExpr.hs view
@@ -0,0 +1,134 @@+-- |+-- Module      :  Data.SExpresso.SExpr+-- Copyright   :  © 2019 Vincent Archambault+-- License     :  0BSD+--+-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>+-- Stability   :  experimental+--+-- Definition of S-expression++{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+++module Data.SExpresso.SExpr+  (+    SExpr(..),+    Sexp,+    pattern A,+    pattern L,+    pattern Sexp,+    pattern (:::),+    pattern Nil,+    isAtom,+    sAtom,+    isList,+    sList+  )+  where++-- | The datatype 'SExpr' is the definition of an S-expression for the+-- library S-expresso.+--+-- The parameter @a@ allows you to specify the datatype of atoms and+-- the parameter @b@ is usefull for keeping metadata about S-expression+-- like source position for example.+data SExpr b a = SList b [SExpr b a]+               | SAtom a+               deriving (Eq, Show, Functor, Traversable, Foldable)++-- | The type synonym 'Sexp' is a variant of the more general 'SExpr'+-- datatype with no data for the 'SList' constructor.+type Sexp a = SExpr () a++-- | Bidirectional pattern synonym for the type synonym 'Sexp'. See+-- also the 'L' pattern synonym.+--+-- >foo (Sexp x) = x -- Equivalent to foo (SList () x) = x+-- >s = Sexp []      -- Equivalent to s = SList () []+pattern Sexp :: [Sexp a] -> Sexp a+pattern Sexp xs = SList () xs++-- | Pattern for matching only the sublist of the 'SList' constructor.+-- See also the Sexp pattern synonym.+--+-- >foo (L xs) = xs -- Equivalent to foo (SList _ xs) = xs+pattern L :: [SExpr b a] -> SExpr b a+pattern L xs <- SList _ xs++-- | Shorthand for 'SAtom'.+--+-- >foo (A x) = x -- Equivalent to foo (SAtom x) = x+-- > a = A 3      -- Equivalent to a = SAtom 3+pattern A :: a -> SExpr b a+pattern A x = SAtom x++uncons :: SExpr b a -> Maybe (SExpr b a, SExpr b a)+uncons (SAtom _) = Nothing+uncons (SList _ []) = Nothing+uncons (SList b (x:xs)) = Just (x, SList b xs)++-- | Pattern specifying the shape of the sublist of the 'SList' constructor.+-- See also 'Nil'.+--+-- Although it aims to mimic the behavior of the cons (:) constructor+-- for list, this pattern behavior is a little bit different. Indeed+-- its signature is @SExpr b a -> SExpr b a -> SExpr b a@ while the+-- cons (:) constructor signature is @a -> [a] -> [a]@. The first+-- argument type is different in the case of the cons constructor but all+-- the types are identical for the pattern `:::`.+--+-- This implies that the following code+--+-- >foo (x ::: xs) = ...+-- is equivalent to+--+-- >foo (SList b (x : rest)) = let xs = SList b rest+-- >                           in ...+-- If you wish for the @xs@ above to match the remaining of the list,+-- you need to use the 'L' pattern+--+-- >foo (A x ::: L xs)+-- which is equivalent to+-- +-- >foo (SList b (x : rest)) = let (SList _ xs) = SList b rest+-- >                           in ...+--+-- Other examples :+--+-- >foo (A x1 ::: A x2 ::: Nil)   -- Equivalent to foo (SList _ [SAtom x1, SAtom x2])+-- >foo (L ys ::: A x ::: L xs)   -- Equivalent to foo (SList _ (SList _ ys : SAtom x : xs))+infixr 5 :::+pattern (:::) :: SExpr b a -> SExpr b a -> SExpr b a+pattern x ::: xs <- (uncons -> Just (x, xs))++-- | Pattern to mark the end of the list when using the pattern synonym ':::'+pattern Nil :: SExpr b a+pattern Nil <- SList _ []++-- | The 'isAtom' function returns 'True' iff its argument is of the+-- form @SAtom _@.+isAtom :: SExpr b a -> Bool+isAtom (A _) = True+isAtom _ = False++-- | The 'sAtom' function returns 'Nothing' if its argument is of the+-- form @SList _ _@ and @'Just' a@ if its argument is of the form @SAtom _@..+sAtom :: SExpr b a -> Maybe a+sAtom (A x) = Just x+sAtom _ = Nothing++-- | The 'isList' function returns 'True' iff its argument is of the+-- form @SList _ _@.+isList :: SExpr b a -> Bool+isList (L _) = True+isList _ = False++-- | The 'sList' function returns 'Nothing' if its argument is of the+-- form @SAtom _@ and the sublist @xs@ if its argument is of the form+-- @SList _ xs@.+sList :: SExpr b a -> Maybe [SExpr b a]+sList (L l) = Just l+sList _ = Nothing
+ test/Parse_Unittests.hs view
@@ -0,0 +1,122 @@+module Parse_Unittests (+  parseTestTree+  )where++import Data.Void+import Data.Either+import Data.Bifunctor (first)+import Test.Tasty+import Test.Tasty.HUnit+import Text.Megaparsec as M+import Text.Megaparsec.Char+import Data.SExpresso.SExpr+import Data.SExpresso.Parse++type Parser = Parsec Void String++asciiLetter :: Parser Char+asciiLetter = oneOf (['a' .. 'z'] ++ ['A' .. 'Z'])++pIdent :: Parser String+pIdent = some asciiLetter++pDigit :: Parser String+pDigit = some digitChar++sexpParser :: SExprParser Parser () String+sexpParser = plainSExprParser (pIdent <|> pDigit)++pSExpr :: Parser (Sexp String)+pSExpr = parseSExpr sexpParser++pDecodeOne :: Parser (Sexp String)+pDecodeOne = decodeOne sexpParser++pDecode :: Parser [Sexp String]+pDecode = decode sexpParser++pOptionalSpace :: Parser (Sexp String)+pOptionalSpace = decodeOne $ setSpacingRule spaceIsOptional sexpParser++parseTestTree :: TestTree+parseTestTree = testGroup "Parse/Generic.hs & Parse/Char.hs unit tests" $+  let tparse :: Parser a -> String -> Either String a+      tparse p s = first M.errorBundlePretty $ M.parse p "" s++      sExprTests :: (Eq a, Show a) => Parser a -> (Sexp String -> a) -> [TestTree]+      sExprTests p f = [+        let s = "()" in testCase (show s) $ tparse p s @?= (Right $ f (SList () [])),+        let s = "(   )" in testCase (show s) $ tparse p s @?= (Right $ f (SList () [])),+        let s = "foo" in testCase (show s) $ tparse p s @?= (Right $ f (SAtom "foo")),+        let s = "1234" in testCase (show s) $ tparse p s @?= (Right $ f (SAtom "1234")),+        let s = "(foo)" in testCase (show s) $ tparse p s @?= (Right $ f (SList () [SAtom "foo"])),+        let s = "( foo)" in testCase (show s) $ tparse p s @?= (Right $ f (SList () [SAtom "foo"])),+        let s = "(foo )" in testCase (show s) $ tparse p s @?= (Right $ f (SList () [SAtom "foo"])),+        let s = "(foo bar baz)"+        in testCase (show s) $ tparse p s @?= (Right $ f (SList () [SAtom "foo", SAtom "bar", SAtom "baz"])),+        let s = "(foo (bar baz))"+        in testCase (show s) $ tparse p s @?=+           (Right $ f (SList () [SAtom "foo", SList () [SAtom "bar", SAtom "baz"]])),+        let s = "(foo(bar baz))"+        in testCase (show s) $ tparse p s @?=+           (Right $ f (SList () [SAtom "foo", SList () [SAtom "bar", SAtom "baz"]])),+        let s = "((foo bar)baz)"+        in testCase (show s) $ tparse p s @?=+           (Right $ f (SList () [SList () [SAtom "foo", SAtom "bar"], SAtom "baz"])),+        let s = "(foo1234)"+        in testCase (show s) $ (isLeft $ tparse p "(foo1234)") @? "Parsing must fail. foo and 1234 are not separated by whitespace"+        ]+                         +      decodeCommon :: (Eq a, Show a) => Parser a -> (Sexp String -> a) -> [TestTree]+      decodeCommon p f = [+        let s = " () " in testCase (show s) $ tparse p s @?= (Right $ f (SList () [])),+        let s = " ()" in testCase (show s) $ tparse p s @?= (Right $ f (SList () [])),+        let s = "() " in testCase (show s) $ tparse p s @?= (Right $ f (SList () [])),+        let s = "   ()   " in testCase (show s) $ tparse p s @?= (Right $ f (SList () []))+        ]+  in+    [+      testGroup "parseSExpr" $ sExprTests pSExpr id +++      [+        let s = " foo"+        in testCase (show s) $ (isLeft $ tparse pSExpr s) @? "Parsing must fail. parseSExpr should not parse whitespace"+      ],+      testGroup "decondeOne" $ sExprTests pDecodeOne id +++      decodeCommon pDecodeOne id +++      [+        let s = "() err" in testCase (show s) $ (isLeft $ tparse pDecodeOne s) @? "Parsing must fail. 2 SExpr",+        let s = "err ()" in testCase (show s) $ (isLeft $ tparse pDecodeOne s) @? "Parsing must fail. 2 SExpr",+        let s = "()err" in testCase (show s) $ (isLeft $ tparse pDecodeOne s) @? "Parsing must fail. 2 SExpr",+        let s = "err()" in testCase (show s) $ (isLeft $ tparse pDecodeOne s) @? "Parsing must fail. 2 SExpr"+      ],+     testGroup "decode" $ sExprTests pDecode (\x -> [x]) +++     decodeCommon pDecode (\x -> [x]) +++      [+        let s = "()()" in testCase (show s) $ tparse pDecode s @?= Right [SList () [], SList () []],+        let s = " ()()" in testCase (show s) $ tparse pDecode s @?= Right [SList () [], SList () []],+        let s = "() ()" in testCase (show s) $ tparse pDecode s @?= Right [SList () [], SList () []],+        let s = "()() " in testCase (show s) $ tparse pDecode s @?= Right [SList () [], SList () []],+        let s = "  ()  ()  " in testCase (show s) $ tparse pDecode s @?= Right [SList () [], SList () []],+        let s = "(foo)(1234)" in testCase (show s) $ tparse pDecode s @?= Right [SList () [SAtom "foo"], SList () [SAtom "1234"]],+        let s = " (foo)(1234)" in testCase (show s) $ tparse pDecode s @?= Right [SList () [SAtom "foo"], SList () [SAtom "1234"]],+        let s = "(foo) (1234)" in testCase (show s) $ tparse pDecode s @?= Right [SList () [SAtom "foo"], SList () [SAtom "1234"]],+        let s = "(foo)(1234) " in testCase (show s) $ tparse pDecode s @?= Right [SList () [SAtom "foo"], SList () [SAtom "1234"]],+        let s = "  (foo)  (1234)  " in testCase (show s) $ tparse pDecode s @?= Right [SList () [SAtom "foo"], SList () [SAtom "1234"]],+        let s = "(foo) 1234" in testCase (show s) $ tparse pDecode s @?= Right [SList () [SAtom "foo"], SAtom "1234"],+        let s = "foo 1234" in testCase (show s) $ tparse pDecode s @?= Right [SAtom "foo", SAtom "1234"],+        let s = "foo(1234)" in testCase (show s) $ tparse pDecode s @?= Right [SAtom "foo", SList () [SAtom "1234"]],+        let s = "(foo)1234" in testCase (show s) $ tparse pDecode s @?= Right [SList () [SAtom "foo"], SAtom "1234"],+        let s = "bar1234"+        in testCase (show s) $ (isLeft $ tparse pDecode s) @? "Parsing must fail. bar and 1234 are not separated by whitespace"+      ],+     testGroup "spaceIsOptional" $ [+        let s = "(foo1234)"+        in testCase (show s) $ tparse pOptionalSpace s @?= (Right (SList () [SAtom "foo", SAtom "1234"])),+        let s = "(foo 1234)"+        in testCase (show s) $ tparse pOptionalSpace s @?= (Right (SList () [SAtom "foo", SAtom "1234"])),+        let s = "(foo1234 bar)"+        in testCase (show s) $ tparse pOptionalSpace s @?= (Right (SList () [SAtom "foo", SAtom "1234", SAtom "bar"])),+        let s = "( foo1234 )"+        in testCase (show s) $ tparse pOptionalSpace s @?= (Right (SList () [SAtom "foo", SAtom "1234"]))+        ]+  ]
+ test/Print_Unittests.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++module Print_Unittests (+  printTestTree+  )where++import Data.Void+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.SmallCheck as SC+import Test.SmallCheck.Series+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Data.Text as T+import Data.SExpresso.SExpr+import Data.SExpresso.Print+import Data.SExpresso.Parse++type Parser = Parsec Void T.Text++instance (Serial m b, Serial m a) => Serial m (SExpr b a) where+  series = cons1 SAtom \/ cons2 SList++printer :: SExprPrinter () Integer+printer = mkPrinter (T.pack . show)++pDigit :: Parser Integer+pDigit = do+  sign <- optional (char '-')+  n <- fmap read (some digitChar)+  case sign of+    Nothing -> return n+    Just _ -> return (-1 * n)++sexpParser :: SExprParser Parser () Integer+sexpParser = plainSExprParser pDigit++printTestTree :: TestTree+printTestTree = testGroup "Print.hs unit tests" $+  [testGroup "flatPrint" [+      testCase "Empty SList" $ flatPrint printer (SList () [] :: Sexp Integer) @?= "()",+      testCase "Singleton SList" $ flatPrint printer (SList () [SAtom 1] :: Sexp Integer) @?= "(1)",+      testCase "SList 1/3" $ flatPrint printer (SList () [SAtom 1, SAtom 2, SAtom 3] :: Sexp Integer) @?= "(1 2 3)",+      testCase "SList 2/3" $ flatPrint printer (SList () [SAtom 1, SList () [SAtom 2], SAtom 3] :: Sexp Integer) @?= "(1 (2) 3)",+      testCase "SList 3/3" $ flatPrint printer (SList () [SList () [SAtom 1], SAtom 2, SList () [SAtom 3]] :: Sexp Integer) @?= "((1) 2 (3))",+      testCase "SAtom" $ flatPrint printer (SAtom 3 :: Sexp Integer) @?= "3",+      SC.testProperty "decodeOne inverse of flatPrint" $+      \s -> parse (decodeOne sexpParser) "" (flatPrint printer (s :: Sexp Integer)) == Right s+      ]+  ]
+ test/SExpr_Unittests.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module SExpr_Unittests (+  sexpTestTree+  )where++import Test.Tasty+import Test.Tasty.HUnit+import Data.SExpresso.SExpr++sexpTestTree :: TestTree+sexpTestTree = testGroup "Sexpr.hs unit tests"++  [testGroup "isList" [+      testCase "Empty SList" $ isList (SList () [] :: Sexp Int) @?= True,+      testCase "SList" $ isList (SList () [SAtom 1, SAtom 2] :: Sexp Int) @?= True,+      testCase "SAtom" $ isList (SAtom 1 :: Sexp Int) @?= False],++   testGroup "sList" [+      testCase "Empty SList" $ sList (SList () [] :: Sexp Int) @?= Just [],+      testCase "SList" $ sList (SList () [SAtom 1, SAtom 2] :: Sexp Int) @?= Just [SAtom 1, SAtom 2],+      testCase "SAtom" $ sList (SAtom 1 :: Sexp Int) @?= Nothing],+    +   testGroup "isAtom" [+      testCase "Empty SList" $ isAtom (SList () [] :: Sexp Int) @?= False,+      testCase "SList" $ isAtom (SList () [SAtom 1, SAtom 2] :: Sexp Int) @?= False,+      testCase "SAtom" $ isAtom (SAtom 1 :: Sexp Int) @?= True],++   testGroup "sAtom" [+      testCase "Empty SList" $ sAtom (SList () [] :: Sexp Int) @?= Nothing,+      testCase "SList" $ sAtom (SList () [SAtom 1, SAtom 2] :: Sexp Int) @?= Nothing,+      testCase "SAtom" $ sAtom (SAtom 1 :: Sexp Int) @?= Just 1],++   testGroup "Pattern synonyms" [+      testCase "L - empty list (1/2)" $+        (case (SList () []) of+           L [] -> True+           _ -> False) @?= True,+      testCase "L - empty list (2/2)" $+        (case (SList () [SAtom 1 :: Sexp Int]) of+           L [] -> True+           _ -> False) @?= False,+      testCase "L - singleton list (1/2)" $+        (case (SList () [SAtom 1 :: Sexp Int]) of+           L [_] -> True+           _ -> False) @?= True,+      testCase "L - singleton list (2/2)" $+        (case (SList () [SAtom 1 :: Sexp Int]) of+           L [] -> True+           _ -> False) @?= False,+      testCase "L - atom" $+        (case (SAtom 1 :: Sexp Int) of+           L _ -> True+           _ -> False) @?= False,+      testCase "A - atom (1/2)" $+        (case (SAtom 1 :: Sexp Int) of+           A 1 -> True+           _ -> False) @?= True,+      testCase "A - atom (2/2)" $+        (case (A 1 :: Sexp Int) of+           SAtom 1 -> True+           _ -> False) @?= True,+      testCase "A - singleton list" $+        (case (SList () [SAtom 1 :: Sexp Int]) of+           A 1 -> True+           _ -> False) @?= False,+      testCase "Sexp - empty List" $+        (Sexp [] :: Sexp Int) @?= SList () [],+      testCase "Sexp - non empty List" $+        Sexp [A 1 :: Sexp Int, A 2] @?= SList () [SAtom 1, SAtom 2],+      testCase "Sexp and L" $+        (case (SList () [SAtom 1 :: Sexp Int, SList () []]) of+           Sexp [A 1, L []] -> True+           _ -> False) @?= True,+      testCase "::: (1/2)" $+        (case (SList () [SAtom 1 :: Sexp Int, SAtom 2]) of+           (A 1 ::: A 2 ::: L []) -> True+           _ -> False) @?= True,+      testCase "::: (2/2)" $+        (case (SList () [SAtom 1 :: Sexp Int, SAtom 2, SAtom 3]) of+           (A 1 ::: L xs) -> xs == [SAtom 2, SAtom 3]+           _ -> False) @?= True,+      testCase "Nil (1/2)" $+        (case (SList () [SAtom 1 :: Sexp Int, SAtom 2]) of+           (A 1 ::: A 2 ::: Nil) -> True+           _ -> False) @?= True,+      testCase "Nil (2/2)" $+        (case (SList () [SAtom 1 :: Sexp Int, SAtom 2, SAtom 3]) of+           (A 1 ::: A 2 ::: Nil) -> True+           _ -> False) @?= False+      ],++    testGroup "Functor" [+      testCase "Empty SList" $ fmap (\x -> x + 1) (SList () [] :: Sexp Int) @?= (SList () []),+      testCase "Singleton SList" $ fmap (\x -> x + 1) (SList () [SAtom 5] :: Sexp Int) @?= (SList () [SAtom 6])]+  ]
+ test/SchemeR5RS_Unittests.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE OverloadedStrings #-}++module SchemeR5RS_Unittests (+  r5rsTestTree+  )where++import Data.Void+import qualified Data.Text as T+import Data.Either+import Data.Bifunctor (first)+import Test.Tasty+import Test.Tasty.HUnit+import Text.Megaparsec+--import Text.Megaparsec.Char+import Data.SExpresso.SExpr+import Data.SExpresso.Parse+import Data.SExpresso.Language.SchemeR5RS as R5++type Parser = Parsec Void T.Text++pSExpr :: Parser [SExpr R5.SExprType R5.SchemeToken]+pSExpr = decode R5.sexpr++-- tparse parses the whole input+tparse :: Parser a -> T.Text -> Either String a+tparse p s = first errorBundlePretty $ parse (p <* eof) "" s+  +r5rsTestTree :: TestTree+r5rsTestTree = testGroup "Language/R5RS.hs" $ [+  testGroup "whitespace" $ [+      let s = " " in testCase (show s) $ tparse R5.whitespace s @?= Right (),+      let s = "\t" in testCase (show s) $ tparse R5.whitespace s @?= Right (),+      let s = "\n" in testCase (show s) $ tparse R5.whitespace s @?= Right (),+      let s = "\r\n" in testCase (show s) $ tparse R5.whitespace s @?= Right (),+      let s = "" in testCase (show s) $ (isLeft $ tparse R5.whitespace s) @? "Parsing must fail on empty input",+      let s = "a" in testCase (show s) $ (isLeft $ tparse R5.whitespace s) @? "Parsing must fail on a",+      let s = ";" in testCase (show s) $ (isLeft $ tparse R5.whitespace s) @? "Parsing must fail on ;"+      ],+  testGroup "comment" $ [+      let s = ";" in testCase (show s) $ tparse R5.comment s @?= Right (),+      let s = ";hello world" in testCase (show s) $ tparse R5.comment s @?= Right (),+      let s = ";hello\n" in testCase (show s) $ tparse R5.comment s @?= Right (),+      let s = ";abcdef\r\n" in testCase (show s) $ tparse R5.comment s @?= Right (),+      let s = "" in testCase (show s) $ (isLeft $ tparse R5.comment s) @? "Parsing must fail on empty input",+      let s = "a" in testCase (show s) $ (isLeft $ tparse R5.comment s) @? "Parsing must fail on a",+      let s = "#t" in testCase (show s) $ (isLeft $ tparse R5.comment s) @? "Parsing must fail on #t"+      ],+  testGroup "interTokenSpace" $ [+      let s = ";" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = ";hello world" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = ";hello\n" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = ";abcdef\r\n" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = " " in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = "\t" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = "\n" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = "\r\n" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = " ;comment\n    " in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = "\t\n;comment   \n   " in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = "\n\n\n\n\n" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = "\r\n;Hello World" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right (),+      let s = "" in testCase (show s) $ tparse R5.interTokenSpace s @?= Right ()+      ],+  testGroup "interTokenSpace1" $ [+      let s = ";" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = ";hello world" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = ";hello\n" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = ";abcdef\r\n" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = " " in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = "\t" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = "\n" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = "\r\n" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = " ;comment\n    " in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = "\t\n;comment   \n   " in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = "\n\n\n\n\n" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = "\r\n;Hello World" in testCase (show s) $ tparse R5.interTokenSpace1 s @?= Right (),+      let s = "" in testCase (show s) $ (isLeft $ tparse R5.interTokenSpace1 s) @? "Parsing must fail on empty input",+      let s = "1234" in testCase (show s) $ (isLeft $ tparse R5.interTokenSpace1 s) @? "Parsing must fail on 1234",+      let s = "a" in testCase (show s) $ (isLeft $ tparse R5.interTokenSpace1 s) @? "Parsing must fail on a",+      let s = "#t" in testCase (show s) $ (isLeft $ tparse R5.interTokenSpace1 s) @? "Parsing must fail on #t"+      ],+  testGroup "character" $ [+      let s = "#\\t" in testCase (show s) $ tparse R5.character s @?= Right 't',+      let s = "#\\a" in testCase (show s) $ tparse R5.character s @?= Right 'a',+      let s = "#\\space" in testCase (show s) $ tparse R5.character s @?= Right ' ',+      let s = "#\\newline" in testCase (show s) $ tparse R5.character s @?= Right '\n',+      let s = "#\\\n" in testCase (show s) $ tparse R5.character s @?= Right '\n',+      let s = "#\\ " in testCase (show s) $ tparse R5.character s @?= Right ' ',+      let s = "#\\\t" in testCase (show s) $ tparse R5.character s @?= Right '\t',+      let s = "" in testCase (show s) $ (isLeft $ tparse R5.character s) @? "Parsing must fail on empty input",+      let s = "#t" in testCase (show s) $ (isLeft $ tparse R5.character s) @? "Parsing must fail on #t",+      let s = "#f" in testCase (show s) $ (isLeft $ tparse R5.character s) @? "Parsing must fail on #f"+      ],+  testGroup "boolean" $ [+      let s = "#t" in testCase (show s) $ tparse R5.boolean s @?= Right True,+      let s = "#f" in testCase (show s) $ tparse R5.boolean s @?= Right False,+      let s = "" in testCase (show s) $ (isLeft $ tparse R5.boolean s) @? "Parsing must fail on empty input",+      let s = "t" in testCase (show s) $ (isLeft $ tparse R5.boolean s) @? "Parsing must fail on t",+      let s = "f" in testCase (show s) $ (isLeft $ tparse R5.boolean s) @? "Parsing must fail on f"+      ],+  testGroup "identifier" $ [+      let s = "foo" in testCase (show s) $ tparse R5.identifier s @?= Right s,+      let s = "x2" in testCase (show s) $ tparse R5.identifier s @?= Right s,+      let s = "!hot!" in testCase (show s) $ tparse R5.identifier s @?= Right s,+      let s = "+" in testCase (show s) $ tparse R5.identifier s @?= Right s,+      let s = "-" in testCase (show s) $ tparse R5.identifier s @?= Right s,+      let s = "..." in testCase (show s) $ tparse R5.identifier s @?= Right s,+      let s = "helloWorld" in testCase (show s) $ tparse R5.identifier s @?= Right s,+      let s = "" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on empty input",+      let s = "#t" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on #t",+      let s = "#f" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on #f",+      let s = "123" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on 123",+      let s = "+123" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on +123",+      let s = "-123" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on -123",+      let s = "+i" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on +i",+      let s = "-i" in testCase (show s) $ (isLeft $ tparse R5.identifier s) @? "Parsing must fail on -i"+      ],+    testGroup "string" $ [+      let s = "\"abc def ghi\"" in testCase (show s) $ tparse R5.stringParser s @?= Right "abc def ghi",+      let s = "\"\"" in testCase (show s) $ tparse R5.stringParser s @?= Right "",+      let s = "\"\n\"" in testCase (show s) $ tparse R5.stringParser s @?= Right "\n",+      let s = "\" \"" in testCase (show s) $ tparse R5.stringParser s @?= Right " ",+      let s = "\"\t\"" in testCase (show s) $ tparse R5.stringParser s @?= Right "\t",+      let s = T.pack ['"','\\','\\','"'] in testCase (show s) $ tparse R5.stringParser s @?= Right "\\",+      let s = T.pack ['"','\\','"','"'] in testCase (show s) $ tparse R5.stringParser s @?= Right "\"",+      let s = "#t" in testCase (show s) $ (isLeft $ tparse R5.stringParser s) @? "Parsing must fail on #t",+      let s = "#f" in testCase (show s) $ (isLeft $ tparse R5.stringParser s) @? "Parsing must fail on #f"+      ],+    testGroup "number" $ [+      let s = "-1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Minus (UInteger 1))),+      let s = "-0" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Minus (UInteger 0 ))),+      let s = "0" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 0))),+      let s = "1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 1))),++      +      let s = "#e1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 1))),+        +      let s = "#i1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Plus (UInteger 1))),+        +      let s = "#b1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 1))),+      let s = "#o1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 1))),+      let s = "#d1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 1))),+      let s = "#x1" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 1))),+      let s = "#xa" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                                                                   CReal (SInteger Plus (UInteger 10))),+      let s = "#xb" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 11))),+      let s = "#xc" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 12))),+      let s = "#xd" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 13))),+      let s = "#xe" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 14))),+      let s = "#xf" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 15))),+      let s = "-0001" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Minus (UInteger 1))),+      let s = "-0000" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Minus (UInteger 0))),+      let s = "0000" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 0))),+      let s = "0001" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 1))),++      let s = "-1#" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Minus (UIntPounds 1 1))),+      let s = "-0#" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Minus (UIntPounds 0 1))),+      let s = "0#" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Plus (UIntPounds 0 1))),+      let s = "1#" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Plus (UIntPounds 1 1))),++      let s = "-1###" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Minus (UIntPounds 1 3))),+      let s = "-0###" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Minus (UIntPounds 0 3))),+      let s = "0###" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Plus (UIntPounds 0 3))),+      let s = "1###" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SInteger Plus (UIntPounds 1 3))),++      let s = "-12345" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Minus (UInteger 12345))),+      let s = "12345" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SInteger Plus (UInteger 12345))),++      let s = "-12345/5" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SRational Minus (UInteger 12345) (UInteger 5))),+      let s = "12345/5" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SRational Plus (UInteger 12345) (UInteger 5))),+      let s = "-12345#/5" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SRational Minus (UIntPounds 12345 1) (UInteger 5))),+      let s = "12345/5##" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SRational Plus (UInteger 12345) (UIntPounds 5 2))),+      let s = "-12345##/5" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SRational Minus (UIntPounds 12345 2) (UInteger 5))),+      let s = "12345####/5#" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SRational Plus (UIntPounds 12345 4) (UIntPounds 5 1))),+++      let s = "-12345.0" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Minus (UInteger 12345) (UInteger 0) Nothing)),+      let s = ".0" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 0) (UInteger 0) Nothing)),+      let s = "0." in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 0) (UInteger 0) Nothing)),+        +      let s = "0.###" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 0) (UPounds 3) Nothing)),+      let s = "-.569" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Minus (UInteger 0) (UInteger 569) Nothing)),+      let s = "-245#." in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Minus (UIntPounds 245 1) (UPounds 0) Nothing)),+      let s = "#e-.569" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CReal (SDecimal Minus (UInteger 0) (UInteger 569) Nothing)),+      let s = "1e10" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 1)+                                                         (UInteger 0)+                                                         (Just $ Suffix PDefault Plus 10))),+      let s = "1e-10" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 1)+                                                         (UInteger 0)+                                                         (Just $ Suffix PDefault Minus 10))),+      let s = "1s10" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 1)+                                                         (UInteger 0)+                                                         (Just $ Suffix PShort Plus 10))),+      let s = "1f10" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 1)+                                                         (UInteger 0)+                                                         (Just $ Suffix PSingle Plus 10))),+      let s = "1d10" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 1)+                                                         (UInteger 0)+                                                         (Just $ Suffix PDouble Plus 10))),+      let s = "1l10" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CReal (SDecimal Plus (UInteger 1)+                                                         (UInteger 0)+                                                         (Just $ Suffix PLong Plus 10))),+        +      let s = "1+i" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CAbsolute (SInteger Plus (UInteger 1)) (SInteger Plus (UInteger 1))),+        +      let s = "1-i" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CAbsolute (SInteger Plus (UInteger 1)) (SInteger Minus (UInteger 1))),++      let s = "0.5+i" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CAbsolute (SDecimal Plus (UInteger 0)+                                                    (UInteger 5)+                                                    Nothing) (SInteger Plus (UInteger 1))),+                                                                     +      let s = "-8i" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CAbsolute (SInteger Plus (UInteger 0)) (SInteger Minus (UInteger 8))),++      +      let s = "-8.25i" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CAbsolute (SInteger Plus (UInteger 0)) (SDecimal Minus (UInteger 8)+                                                                                      (UInteger 25)+                                                                                      Nothing)),+      let s = "0@25" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CAngle (SInteger Plus (UInteger 0)) (SInteger Plus (UInteger 25))),++      let s = "1/4@-25" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Exact $+                      CAngle (SRational Plus (UInteger 1) (UInteger 4)) (SInteger Minus (UInteger 25))),++      let s = "1#/4@-25##" in testCase (show s) $ tparse R5.number s @?= (Right $ SchemeNumber Inexact $+                      CAngle (SRational Plus (UIntPounds 1 1) (UInteger 4)) (SInteger Minus (UIntPounds 25 2))),++      let s = "#b3" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #b3",+      let s = "#o9" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #o9",+      let s = "#da" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #da",+      let s = "#xA" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #xA",+      +      let s = "#b1.1" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #b1.1",+      let s = "#o1.1" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #o1.1",+      let s = "#x1.1" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #x1.1",+      let s = "#b.1" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #b.1",+      let s = "#o.1" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #o.1",+      let s = "#x.1" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #x.1",+      +      let s = "123##.12" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on 123##.12",+      let s = "#" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #",+      let s = "#t" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #t",+      let s = "#f" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on #f"+      ],+    testGroup "datum" $ [+      let s = "1" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DNumber (SchemeNumber Exact (CReal (SInteger Plus (UInteger 1))))]),+        +      let s = "foo" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DIdentifier "foo"]),+      let s = "(foo #\\a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DList [DIdentifier "foo", DChar 'a']]),+      let s = "(foo #\\a) \"hello\"" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DList [DIdentifier "foo", DChar 'a'], DString "hello"]),+        +      let s = "'foo" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuote (DIdentifier "foo")]),+      let s = "`foo" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuasiquote (DIdentifier "foo")]),+      let s = "`(foo ,a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),+      let s = "`(foo , a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),+      let s = "`(foo, a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),+      let s = "`(foo ,@a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),+      let s = "`(foo ,@ a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),+      let s = "`(foo,@ a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),+      let s = "(foo . a)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DDotList [DIdentifier "foo"] (DIdentifier "a")]),+      let s = "(foo a b c . d)" in testCase (show s) $ (tparse pSExpr s >>= sexpr2Datum) @?=+                     (Right $ [DDotList [DIdentifier "foo", DIdentifier "a", DIdentifier "b", DIdentifier "c"] (DIdentifier "d")]),+      let s = "(foo .)" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on (foo .)",+      let s = "(foo ')" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on (foo ')",+      let s = "(foo `)" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on (foo `)",+      let s = "(foo ,)" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on (foo ,)",+      let s = "(foo ,@)" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on (foo ,@)",+      let s = "(foo a b . c d)" in testCase (show s) $ (isLeft $ tparse R5.number s) @? "Parsing must fail on (foo a b . c d)"+      ]+  ]
+ test/Spec.hs view
@@ -0,0 +1,14 @@++module Main where++import Test.Tasty+import SExpr_Unittests+import Parse_Unittests+import Print_Unittests+import SchemeR5RS_Unittests++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "tests" [sexpTestTree, parseTestTree, printTestTree, r5rsTestTree]