sexpresso 1.0.0.2 → 1.1.0.0

raw patch · 9 files changed

+383/−401 lines, 9 filesdep +bifunctorsdep +recursion-schemesdep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors, recursion-schemes

Dependency ranges changed: megaparsec

API changes (from Hackage documentation)

Files

• ChangeLog.md +15/−37
• README.md +3/−0
• sexpresso.cabal +8/−4
• src/Data/SExpresso/Language/SchemeR5RS.hs +47/−58
• src/Data/SExpresso/Parse/Generic.hs +3/−2
• src/Data/SExpresso/Parse/Location.hs +14/−2
• src/Data/SExpresso/Print/Lazy.hs +3/−3
• src/Data/SExpresso/SExpr.hs +11/−0
• test/SchemeR5RS_Unittests.hs +279/−295

@@ -1,46 +1,24 @@ # 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+Version 1.1.0.0 --------------- -* Fix documentation error for the pattern :::+* Add startPosPretty and endPosPretty function+* Add Bifunctor, Bifoldable and Bitraversable instances for SExpr+* Add Base SExpr, Recursive, Corecursive instances (see package recursion-schemes)+* Add Functor instance for Located+* Fix SExprPrinter constructor name (SExprParser -> SExprPrinter)+* Improve documentation+* Merge [pull request \#6](https://github.com/archambaultv/sexpresso/pull/6) to prepare for MonadFail+* Fix bug with R5RS negative number (issue \#7 on [github](https://github.com/archambaultv/sexpresso/issues/7))+* Tested with stack version 14.27 and 15.3 -Version 0.1.1.0+Version 1.0.0.2 --------------- -* Add Scheme R5RS language--Version 0.1.0.0---------------- --* SExpr datatype+* Initial Hackage Release+* SExpr datatype for representing S-expression * Generic SExpr parser-* SExpr parser for character+* Specialized SExpr parser for character * SExpr flat printer+* Scheme R5RS parser implementation

@@ -1,3 +1,6 @@+[![License OBSD](https://img.shields.io/badge/license-0BSD-brightgreen.svg)](https://opensource.org/licenses/0BSD)+[![Hackage](https://img.shields.io/hackage/v/sexpresso.svg)](http://hackage.haskell.org/package/sexpresso)+ # S-expresso  S-expresso is a Haskell library designed to help you parse and print

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d10313f25fa0bc844633d9e84210f3959d3915bbee2d0c767e121aa3ddd2bd5f+-- hash: cd4a5d89acd75970af22375142f81c7b7320e72ae7403de680177c6ad12e1116  name:           sexpresso-version:        1.0.0.2+version:        1.1.0.0 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@@ -44,8 +44,10 @@   ghc-options: -Wall   build-depends:       base >=4.7 && <5+    , bifunctors >=5.5 && <5.6     , containers >=0.5 && <0.7-    , megaparsec >=7.0 && <8.0+    , megaparsec >=7.0 && <=8.0.0+    , recursion-schemes >=5.1 && <5.2     , text >=0.2 && <1.3   default-language: Haskell2010 @@ -63,8 +65,10 @@   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N   build-depends:       base >=4.7 && <5+    , bifunctors >=5.5 && <5.6     , containers >=0.5 && <0.7-    , megaparsec >=7.0 && <8.0+    , megaparsec >=7.0 && <=8.0.0+    , recursion-schemes >=5.1 && <5.2     , sexpresso     , smallcheck >=1.0     , tasty >=0.8

@@ -1,5 +1,5 @@ -- |--- Module      :  Data.SExpresso.SExpr+-- Module      :  Data.SExpresso.Language.SchemeR5RS -- Copyright   :  © 2019 Vincent Archambault -- License     :  0BSD --@@ -21,7 +21,7 @@ -- 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 +  -- * SchemeToken and Datum related data types and functions   SExprType(..),   SchemeToken(..),   tokenParser,@@ -74,6 +74,7 @@    ) where +import Control.Monad (mzero) import Data.Maybe import Data.Proxy import Data.List@@ -81,6 +82,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B+import Data.Foldable import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as ML@@ -121,16 +123,17 @@               -- character must come before number               (character >>= return . TChar) <|>               (stringParser >>= return . TString) <|>+              -- We must try number because it can conflict with+              -- the dot ex : .2 and (a . b)+              -- and identifier ex : - and -1+              (try number >>= return . TNumber) <|>               (identifier >>= return . TIdentifier) <|>               (quote >> return TQuote) <|>               (quasiquote >> return TQuasiquote) <|>               -- commaAt must come before comma-              (commaAt >> return TCommaAt) <|> +              (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@@ -191,51 +194,37 @@ -- '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+sexpr2Datum = foldrM vectorFold []+  where vectorFold :: SExpr SExprType SchemeToken -> [Datum] -> Either String [Datum]+        vectorFold (SAtom TQuote) [] = Left $ "Expecting a datum after a quote"+        vectorFold (SAtom TQuote) (x : xs) = pure $ DQuote x : xs+        vectorFold (SAtom TQuasiquote) [] = Left $ "Expecting a datum after a quasiquote"+        vectorFold (SAtom TQuasiquote) (x : xs) = pure $ DQuasiquote x : xs+        vectorFold (SAtom TComma) [] = Left $ "Expecting a datum after a comma"+        vectorFold (SAtom TComma) (x : xs) = pure $ DComma x : xs+        vectorFold (SAtom TCommaAt) [] = Left $ "Expecting a datum after a commaAt"+        vectorFold (SAtom TCommaAt) (x : xs) = pure $ DCommaAt x : xs+        vectorFold (SAtom TDot) _ = Left "Unexpected dot"+        vectorFold (SList STVector xs) acc = ((:) . DVector) <$> sexpr2Datum xs <*> pure acc+        vectorFold (SList STList xs) acc =+          let chooseConstructor (isDotList, ls) = (:) (if isDotList+                                                       then DDotList (init ls) (last ls)+                                                       else DList ls)+          in chooseConstructor <$> (foldrM listFold (False, []) xs) <*> pure acc+        vectorFold (SAtom x) acc = pure $ simpleToken x : acc +        simpleToken :: SchemeToken -> Datum+        simpleToken (TBoolean x) = DBoolean x+        simpleToken (TNumber x) = DNumber x+        simpleToken (TChar x) = DChar x+        simpleToken (TString x) = DString x+        simpleToken (TIdentifier x) = DIdentifier x+        simpleToken _ = error "simpleToken only handles a subset of SchemeToken constructors" +        listFold :: SExpr SExprType SchemeToken -> (Bool, [Datum]) -> Either String (Bool, [Datum])+        listFold (SAtom TDot) (_, [x]) = pure (True, [x])+        listFold x (d, acc) = (,) d <$> vectorFold x acc+ ------------------------- 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 ()@@ -435,7 +424,7 @@   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@@ -465,7 +454,7 @@           -- Real +/- Imaginary number           Just '+' -> imaginaryPart n1 Plus           Just _ -> imaginaryPart n1 Minus-  +     imaginaryPart realN si = do       u <- optional (ureal r si)       _ <- char 'i'@@ -484,7 +473,7 @@   where dotN =  do           _ <- char '.'           if r /= R10-          then fail "Numbers containing decimal point must be in decimal radix"+          then label "Numbers containing decimal point must be in decimal radix" mzero           else do              n <- uinteger R10              sf <- optional suffix@@ -508,14 +497,14 @@             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"+          then label "Numbers containing decimal point must be in decimal radix" mzero           else do              -- If u1 has # character, only other # are              -- allowed. Otherwise a number may be present@@ -539,8 +528,8 @@   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 '#'@@ -560,14 +549,14 @@ 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@@ -578,7 +567,7 @@   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) 

@@ -61,6 +61,7 @@ import Data.Maybe import qualified Data.Map as M import Control.Applicative+import Control.Monad (mzero) import Text.Megaparsec import Data.SExpresso.SExpr import Data.SExpresso.Parse.Location@@ -270,8 +271,8 @@               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))+              else label ("The previous two atoms are not separated by space.\n" <>+                         "A space was expected at " <> sourcePosPretty (fromJust mpos)) mzero  -- | The 'parseSExprList' function return a parser for parsing S-expression of the form @'SList' _ _@. parseSExprList :: (MonadParsec e s m) =>

@@ -9,11 +9,15 @@ -- The module "Data.SExpresso.Parse" re-exports the functions and -- datatypes of this module. +{-# LANGUAGE DeriveFunctor #-}+ module Data.SExpresso.Parse.Location   (     Location(..),     Located(..),-    located+    located,+    startPosPretty,+    endPosPretty    )   where @@ -25,9 +29,17 @@ data Location = Span SourcePos SourcePos               deriving (Eq, Ord, Show) +-- | Pretty prints @S1@ of a @'Span' S1 _@ object with 'sourcePosPretty'+startPosPretty :: Location -> String+startPosPretty (Span s _) = sourcePosPretty s++-- | Pretty prints @S2@ of a @'Span' _ S2@ object with 'sourcePosPretty'+endPosPretty :: Location -> String+endPosPretty (Span _ s) = sourcePosPretty s+ -- | The 'Located' datatype adds a source span to the type @a@ data Located a = At Location a-               deriving (Eq, Ord, Show)+               deriving (Eq, Ord, Show, Functor)  -- | The 'located' function adds a source span to a parser. located :: (MonadParsec e s m) => m a -> m (Located a)

@@ -23,8 +23,8 @@ 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 'SExprPrinter' defines how to print an 'SExpr'.+data SExprPrinter b a = SExprPrinter {   -- | 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@@ -34,7 +34,7 @@ -- | 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+mkPrinter p = SExprPrinter (\_ _ -> ("(", ")")) 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

@@ -10,6 +10,9 @@  {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}  @@ -29,6 +32,9 @@   )   where +import Data.Bifunctor.TH+import Data.Functor.Foldable.TH+ -- | The datatype 'SExpr' is the definition of an S-expression for the -- library S-expresso. --@@ -38,6 +44,11 @@ data SExpr b a = SList b [SExpr b a]                | SAtom a                deriving (Eq, Show, Functor, Traversable, Foldable)++$(deriveBifunctor ''SExpr)+$(deriveBifoldable ''SExpr)+$(deriveBitraversable ''SExpr)+$(makeBaseFunctor ''SExpr)  -- | The type synonym 'Sexp' is a variant of the more general 'SExpr' -- datatype with no data for the 'SList' constructor.

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  module SchemeR5RS_Unittests (   r5rsTestTree@@ -24,311 +25,294 @@ -- 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))),+-- Runs a test that must succeed. Accepts the parser and+-- the string to parse and the expected value as tuple+okTest :: (Eq a, Show a) => Parser a -> (T.Text, a) -> TestTree+okTest p (str, expected) = testCase ("Should parse " ++ show str)+                         $ tparse p str @?= Right expected -      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))),+okDatum :: (T.Text, [Datum]) -> TestTree+okDatum (t, d) = okTest (sexpr2Datum <$> pSExpr) (t, Right d) -      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))),+-- Runs a test that must fail. Accepts the parser+-- and the string to parse+koTest :: Parser a -> T.Text -> TestTree+koTest p str = testCase ("Should not parse " ++ show str)+             $ (isLeft $ tparse p str) @?+               ("Parsing must fail on " ++ show str) -      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))),+koDatum :: T.Text -> TestTree+koDatum str = testCase ("Should not parse " ++ show str)+             $ (isLeft $ (tparse pSExpr str >>= sexpr2Datum)) @?+               ("Parsing must fail on " ++ show str) -      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))),+-- Tests about whitespace that must succeed (see okTest)+okWhitespace :: [(T.Text, ())]+okWhitespace = map (,()) [" ", "\t", "\n", "\r\n"] +-- Tests about comment that must succeed (see okTest)+okComment :: [(T.Text, ())]+okComment = map (,()) [";", ";hello world", ";hello\n", ";abcdef\r\n"] -      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))),+okInterTokenSpace1 :: [(T.Text, ())]+okInterTokenSpace1 = okWhitespace+                  ++ okComment+                  ++ map (,()) [" ;comment\n    ",+                     "\t\n;comment   \n   ",+                     "\n\n\n\n\n",+                     "\r\n;Hello World",+                     "  ;comment\n   ;comment"] -      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))),+okInterTokenSpace :: [(T.Text, ())]+okInterTokenSpace = okInterTokenSpace1 ++ map (,()) [""] -      -      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))),+okChar :: [(T.Text, Char)]+okChar = [("#\\t", 't'),+          ("#\\a", 'a'),+          ("#\\space", ' '),+          ("#\\newline", '\n'),+          ("#\\\n", '\n'),+          ("#\\ ", ' '),+          ("#\\\t", '\t')] -      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))),+okBool :: [(T.Text, Bool)]+okBool = [("#t", True),+          ("#f", False)] -      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))),+okIdentifier :: [(T.Text, T.Text)]+okIdentifier = map (\x -> (x,x)) ["foo", "x2", "!hot!", "+", "-", "...",+                                  "helloWorld"] -      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)"-      ]+okString :: [(T.Text, T.Text)]+okString = [("\"abc def ghi\"", "abc def ghi"),+            ("\"\"", ""),+            ("\"\n\"", "\n"),+            ("\" \"", " "),+            ("\"\t\"", "\t"),+            (T.pack ['"','\\','\\','"'], "\\"),+            (T.pack ['"','\\','"','"'], "\"")]++okNumber :: [(T.Text, SchemeNumber)]+okNumber =  [("-1", SchemeNumber Exact $+                    CReal (SInteger Minus (UInteger 1))),+    ("-0", SchemeNumber Exact $+                    CReal (SInteger Minus (UInteger 0 ))),+    ("0", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 0))),+    ("1", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 1))),+++    ("#e1", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 1))),++    ("#i1", SchemeNumber Inexact $+                    CReal (SInteger Plus (UInteger 1))),++    ("#b1", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 1))),+    ("#o1", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 1))),+    ("#d1", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 1))),+    ("#x1", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 1))),+    ("#xa", SchemeNumber Exact $ CReal (SInteger Plus (UInteger 10))),+    ("#xb", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 11))),+    ("#xc", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 12))),+    ("#xd", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 13))),+    ("#xe", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 14))),+    ("#xf", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 15))),+    ("-0001", SchemeNumber Exact $+                    CReal (SInteger Minus (UInteger 1))),+    ("-0000", SchemeNumber Exact $+                    CReal (SInteger Minus (UInteger 0))),+    ("0000", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 0))),+    ("0001", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 1))),++    ("-1#", SchemeNumber Inexact $+                    CReal (SInteger Minus (UIntPounds 1 1))),+    ("-0#", SchemeNumber Inexact $+                    CReal (SInteger Minus (UIntPounds 0 1))),+    ("0#", SchemeNumber Inexact $+                    CReal (SInteger Plus (UIntPounds 0 1))),+    ("1#", SchemeNumber Inexact $+                    CReal (SInteger Plus (UIntPounds 1 1))),++    ("-1###", SchemeNumber Inexact $+                    CReal (SInteger Minus (UIntPounds 1 3))),+    ("-0###", SchemeNumber Inexact $+                    CReal (SInteger Minus (UIntPounds 0 3))),+    ("0###", SchemeNumber Inexact $+                    CReal (SInteger Plus (UIntPounds 0 3))),+    ("1###", SchemeNumber Inexact $+                    CReal (SInteger Plus (UIntPounds 1 3))),++    ("-12345", SchemeNumber Exact $+                    CReal (SInteger Minus (UInteger 12345))),+    ("12345", SchemeNumber Exact $+                    CReal (SInteger Plus (UInteger 12345))),++    ("-12345/5", SchemeNumber Exact $+                    CReal (SRational Minus (UInteger 12345) (UInteger 5))),+    ("12345/5", SchemeNumber Exact $+                    CReal (SRational Plus (UInteger 12345) (UInteger 5))),+    ("-12345#/5", SchemeNumber Inexact $+                    CReal (SRational Minus (UIntPounds 12345 1) (UInteger 5))),+    ("12345/5##", SchemeNumber Inexact $+                    CReal (SRational Plus (UInteger 12345) (UIntPounds 5 2))),+    ("-12345##/5", SchemeNumber Inexact $+                    CReal (SRational Minus (UIntPounds 12345 2) (UInteger 5))),+    ("12345####/5#", SchemeNumber Inexact $+                    CReal (SRational Plus (UIntPounds 12345 4) (UIntPounds 5 1))),+++    ("-12345.0", SchemeNumber Inexact $+                    CReal (SDecimal Minus (UInteger 12345) (UInteger 0) Nothing)),+    (".0", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 0) (UInteger 0) Nothing)),+    ("0.", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 0) (UInteger 0) Nothing)),++    ("0.###", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 0) (UPounds 3) Nothing)),+    ("-.569", SchemeNumber Inexact $+                    CReal (SDecimal Minus (UInteger 0) (UInteger 569) Nothing)),+    ("-245#.", SchemeNumber Inexact $+                    CReal (SDecimal Minus (UIntPounds 245 1) (UPounds 0) Nothing)),+    ("#e-.569", SchemeNumber Exact $+                    CReal (SDecimal Minus (UInteger 0) (UInteger 569) Nothing)),+    ("1e10", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 1)+                                                       (UInteger 0)+                                                       (Just $ Suffix PDefault Plus 10))),+    ("1e-10", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 1)+                                                       (UInteger 0)+                                                       (Just $ Suffix PDefault Minus 10))),+    ("1s10", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 1)+                                                       (UInteger 0)+                                                       (Just $ Suffix PShort Plus 10))),+    ("1f10", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 1)+                                                       (UInteger 0)+                                                       (Just $ Suffix PSingle Plus 10))),+    ("1d10", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 1)+                                                       (UInteger 0)+                                                       (Just $ Suffix PDouble Plus 10))),+    ("1l10", SchemeNumber Inexact $+                    CReal (SDecimal Plus (UInteger 1)+                                                       (UInteger 0)+                                                       (Just $ Suffix PLong Plus 10))),++    ("1+i", SchemeNumber Exact $+                    CAbsolute (SInteger Plus (UInteger 1)) (SInteger Plus (UInteger 1))),++    ("1-i", SchemeNumber Exact $+                    CAbsolute (SInteger Plus (UInteger 1)) (SInteger Minus (UInteger 1))),++    ("0.5+i", SchemeNumber Inexact $+                    CAbsolute (SDecimal Plus (UInteger 0)+                                                  (UInteger 5)+                                                  Nothing) (SInteger Plus (UInteger 1))),++    ("-8i", SchemeNumber Exact $+                    CAbsolute (SInteger Plus (UInteger 0)) (SInteger Minus (UInteger 8))),+++    ("-8.25i", SchemeNumber Inexact $+                    CAbsolute (SInteger Plus (UInteger 0)) (SDecimal Minus (UInteger 8)+                                                                                    (UInteger 25)+                                                                                    Nothing)),+    ("0@25", SchemeNumber Exact $+                    CAngle (SInteger Plus (UInteger 0)) (SInteger Plus (UInteger 25))),++    ("1/4@-25", SchemeNumber Exact $+                    CAngle (SRational Plus (UInteger 1) (UInteger 4)) (SInteger Minus (UInteger 25))),++    ("1#/4@-25##", SchemeNumber Inexact $+                    CAngle (SRational Plus (UIntPounds 1 1) (UInteger 4)) (SInteger Minus (UIntPounds 25 2)))]++-- Returns all the "ok..." series of tests except the one provided+-- as input. Since R5RS grammar is non ambiguous, a token parser should not be able+-- to parse the valid input of other token parser.+mkKoTest :: [T.Text] -> [T.Text]+mkKoTest goodStr =+  let allTests = map fst okInterTokenSpace +++                 map fst okChar +++                 map fst okBool +++                 map fst okIdentifier +++                 map fst okString +++                 map fst okNumber+  in filter (not . (`elem` goodStr)) (alwaysBad ++ allTests)++-- Always bad string input+alwaysBad :: [T.Text]+alwaysBad = ["#", "#T", "#F", "#true", "#false"] +++          -- Ill formated number+            ["#b3", "#o9", "#da", "#xA", "#b1.1", "#o1.1", "#x1.1", "#b.1",+             "#o.1", "#x.1", "123##.12"]++r5rsTestTree :: TestTree+r5rsTestTree = testGroup "Language/R5RS.hs" $ [+  testGroup "whitespace" $+      map (okTest R5.whitespace) okWhitespace +++      map (koTest R5.whitespace) (mkKoTest $ map fst okWhitespace),+  testGroup "comment" $+      map (okTest R5.comment) okComment +++      map (koTest R5.comment) (mkKoTest $ map fst okComment),+  testGroup "interTokenSpace" $+      map (okTest R5.interTokenSpace) okInterTokenSpace +++      map (koTest R5.interTokenSpace) (mkKoTest $ map fst okInterTokenSpace),+  testGroup "interTokenSpace1" $+      map (okTest R5.interTokenSpace1) okInterTokenSpace1 +++      map (koTest R5.interTokenSpace1) (mkKoTest $ map fst okInterTokenSpace1),+  testGroup "character" $+      map (okTest R5.character) okChar +++      map (koTest R5.character) (mkKoTest $ map fst okChar),+  testGroup "boolean" $+      map (okTest R5.boolean) okBool +++      map (koTest R5.boolean) (mkKoTest $ map fst okBool),+  testGroup "identifier" $+        map (okTest R5.identifier) okIdentifier +++        map (koTest R5.identifier) (mkKoTest $ map fst okIdentifier),+  testGroup "string" $+        map (okTest R5.stringParser) okString +++        map (koTest R5.stringParser) (mkKoTest $ map fst okString),+  testGroup "number" $+        map (okTest R5.number) okNumber +++        map (koTest R5.number) (mkKoTest $ map fst okNumber),++    testGroup "datum" $+      map okDatum (map (fmap ( (:[]) . DChar)) okChar) +++      map okDatum (map (fmap ( (:[]) . DBoolean)) okBool) +++      map okDatum (map (fmap ( (:[]) . DIdentifier)) okIdentifier) +++      map okDatum (map (fmap ( (:[]) . DString)) okString) +++      map okDatum (map (fmap ( (:[]) . DNumber)) okNumber) +++      map okDatum+      [("(foo #\\a)", [DList [DIdentifier "foo", DChar 'a']]),+       ("(foo #\\a) \"hello\"", [DList [DIdentifier "foo", DChar 'a'], DString "hello"]),+       ("'foo", [DQuote (DIdentifier "foo")]),+       ("`foo", [DQuasiquote (DIdentifier "foo")]),+       ("`(foo ,a)", [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),+       ("`(foo , a)", [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),+       ("`(foo, a)", [DQuasiquote (DList [DIdentifier "foo", DComma (DIdentifier "a")])]),+       ("`(foo ,@a)", [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),+       ("`(foo ,@ a)", [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),+       ("`(foo,@ a)", [DQuasiquote (DList [DIdentifier "foo", DCommaAt (DIdentifier "a")])]),+       ("(foo . a)", [DDotList [DIdentifier "foo"] (DIdentifier "a")]),+       ("(foo a b c . d)",+        [DDotList [DIdentifier "foo", DIdentifier "a", DIdentifier "b", DIdentifier "c"] (DIdentifier "d")])]+      +++      map koDatum ["(foo .)", "(foo ')", "(foo `)", "(foo ,)", "(foo ,@)", "(foo a b . c d)"]   ]