-- |
-- Module      :  Data.SExpresso.Language.SchemeR5RS
-- 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 Control.Monad (mzero)
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 Data.Foldable
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 (SchemeToken -> SchemeToken -> Bool
(SchemeToken -> SchemeToken -> Bool)
-> (SchemeToken -> SchemeToken -> Bool) -> Eq SchemeToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemeToken -> SchemeToken -> Bool
$c/= :: SchemeToken -> SchemeToken -> Bool
== :: SchemeToken -> SchemeToken -> Bool
$c== :: SchemeToken -> SchemeToken -> Bool
Eq, Int -> SchemeToken -> ShowS
[SchemeToken] -> ShowS
SchemeToken -> String
(Int -> SchemeToken -> ShowS)
-> (SchemeToken -> String)
-> ([SchemeToken] -> ShowS)
-> Show SchemeToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemeToken] -> ShowS
$cshowList :: [SchemeToken] -> ShowS
show :: SchemeToken -> String
$cshow :: SchemeToken -> String
showsPrec :: Int -> SchemeToken -> ShowS
$cshowsPrec :: Int -> SchemeToken -> ShowS
Show)

-- | The 'tokenParser' parses a 'SchemeToken'
tokenParser :: (MonadParsec e s m, Token s ~ Char) => m SchemeToken
tokenParser :: m SchemeToken
tokenParser = (m Bool
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Bool
boolean m Bool -> (Bool -> m SchemeToken) -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemeToken -> m SchemeToken)
-> (Bool -> SchemeToken) -> Bool -> m SchemeToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SchemeToken
TBoolean) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              -- character must come before number
              (m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
character m Char -> (Char -> m SchemeToken) -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemeToken -> m SchemeToken)
-> (Char -> SchemeToken) -> Char -> m SchemeToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> SchemeToken
TChar) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              (m Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Text
stringParser m Text -> (Text -> m SchemeToken) -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemeToken -> m SchemeToken)
-> (Text -> SchemeToken) -> Text -> m SchemeToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SchemeToken
TString) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              -- We must try number because it can conflict with
              -- the dot ex : .2 and (a . b)
              -- and identifier ex : - and -1
              (m SchemeNumber -> m SchemeNumber
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m SchemeNumber
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m SchemeNumber
number m SchemeNumber -> (SchemeNumber -> m SchemeToken) -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemeToken -> m SchemeToken)
-> (SchemeNumber -> SchemeToken) -> SchemeNumber -> m SchemeToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemeNumber -> SchemeToken
TNumber) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              (m Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Text
identifier m Text -> (Text -> m SchemeToken) -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemeToken -> m SchemeToken)
-> (Text -> SchemeToken) -> Text -> m SchemeToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SchemeToken
TIdentifier) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              (m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
quote m Char -> m SchemeToken -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return SchemeToken
TQuote) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              (m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
quasiquote m Char -> m SchemeToken -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return SchemeToken
TQuasiquote) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              -- commaAt must come before comma
              (m Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Text
commaAt m Text -> m SchemeToken -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return SchemeToken
TCommaAt) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              (m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
comma m Char -> m SchemeToken -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return SchemeToken
TComma) m SchemeToken -> m SchemeToken -> m SchemeToken
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
              (m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
dot m Char -> m SchemeToken -> m SchemeToken
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SchemeToken -> m SchemeToken
forall (m :: * -> *) a. Monad m => a -> m a
return SchemeToken
TDot)


spacingRule :: SchemeToken -> SpacingRule
spacingRule :: SchemeToken -> SpacingRule
spacingRule (TString Text
_) = SpacingRule
SOptional
spacingRule SchemeToken
TQuote = SpacingRule
SOptional
spacingRule SchemeToken
TQuasiquote  = SpacingRule
SOptional
spacingRule SchemeToken
TComma = SpacingRule
SOptional
spacingRule SchemeToken
TCommaAt = SpacingRule
SOptional
spacingRule SchemeToken
_ = 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 (SExprType -> SExprType -> Bool
(SExprType -> SExprType -> Bool)
-> (SExprType -> SExprType -> Bool) -> Eq SExprType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SExprType -> SExprType -> Bool
$c/= :: SExprType -> SExprType -> Bool
== :: SExprType -> SExprType -> Bool
$c== :: SExprType -> SExprType -> Bool
Eq, Int -> SExprType -> ShowS
[SExprType] -> ShowS
SExprType -> String
(Int -> SExprType -> ShowS)
-> (SExprType -> String)
-> ([SExprType] -> ShowS)
-> Show SExprType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SExprType] -> ShowS
$cshowList :: [SExprType] -> ShowS
show :: SExprType -> String
$cshow :: SExprType -> String
showsPrec :: Int -> SExprType -> ShowS
$cshowsPrec :: Int -> SExprType -> ShowS
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 :: SExprParser m SExprType SchemeToken
sexpr =
  let sTag :: m SExprType
sTag = (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'(' m Char -> m SExprType -> m SExprType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SExprType -> m SExprType
forall (m :: * -> *) a. Monad m => a -> m a
return SExprType
STList) m SExprType -> m SExprType -> m SExprType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#(") m (Tokens s) -> m SExprType -> m SExprType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SExprType -> m SExprType
forall (m :: * -> *) a. Monad m => a -> m a
return SExprType
STVector)
      eTag :: b -> m b
eTag = \b
t -> Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
')' m Char -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
t
  in m SExprType
-> (SExprType -> m SExprType)
-> m SchemeToken
-> m ()
-> (SchemeToken -> SchemeToken -> SpacingRule)
-> SExprParser m SExprType SchemeToken
forall (m :: * -> *) b a c.
m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
SExprParser m SExprType
sTag SExprType -> m SExprType
forall b. b -> m b
eTag m SchemeToken
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m SchemeToken
tokenParser m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
interTokenSpace1 ((SchemeToken -> SpacingRule)
-> SchemeToken -> SchemeToken -> SpacingRule
forall a. (a -> SpacingRule) -> a -> a -> SpacingRule
mkSpacingRule SchemeToken -> SpacingRule
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 (Datum -> Datum -> Bool
(Datum -> Datum -> Bool) -> (Datum -> Datum -> Bool) -> Eq Datum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Datum -> Datum -> Bool
$c/= :: Datum -> Datum -> Bool
== :: Datum -> Datum -> Bool
$c== :: Datum -> Datum -> Bool
Eq, Int -> Datum -> ShowS
[Datum] -> ShowS
Datum -> String
(Int -> Datum -> ShowS)
-> (Datum -> String) -> ([Datum] -> ShowS) -> Show Datum
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Datum] -> ShowS
$cshowList :: [Datum] -> ShowS
show :: Datum -> String
$cshow :: Datum -> String
showsPrec :: Int -> Datum -> ShowS
$cshowsPrec :: Int -> Datum -> ShowS
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 :: [SExpr SExprType SchemeToken] -> Either String [Datum]
sexpr2Datum = (SExpr SExprType SchemeToken -> [Datum] -> Either String [Datum])
-> [Datum]
-> [SExpr SExprType SchemeToken]
-> Either String [Datum]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM SExpr SExprType SchemeToken -> [Datum] -> Either String [Datum]
vectorFold []
  where vectorFold :: SExpr SExprType SchemeToken -> [Datum] -> Either String [Datum]
        vectorFold :: SExpr SExprType SchemeToken -> [Datum] -> Either String [Datum]
vectorFold (SAtom SchemeToken
TQuote) [] = String -> Either String [Datum]
forall a b. a -> Either a b
Left (String -> Either String [Datum])
-> String -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ String
"Expecting a datum after a quote"
        vectorFold (SAtom SchemeToken
TQuote) (Datum
x : [Datum]
xs) = [Datum] -> Either String [Datum]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Datum] -> Either String [Datum])
-> [Datum] -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ Datum -> Datum
DQuote Datum
x Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: [Datum]
xs
        vectorFold (SAtom SchemeToken
TQuasiquote) [] = String -> Either String [Datum]
forall a b. a -> Either a b
Left (String -> Either String [Datum])
-> String -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ String
"Expecting a datum after a quasiquote"
        vectorFold (SAtom SchemeToken
TQuasiquote) (Datum
x : [Datum]
xs) = [Datum] -> Either String [Datum]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Datum] -> Either String [Datum])
-> [Datum] -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ Datum -> Datum
DQuasiquote Datum
x Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: [Datum]
xs
        vectorFold (SAtom SchemeToken
TComma) [] = String -> Either String [Datum]
forall a b. a -> Either a b
Left (String -> Either String [Datum])
-> String -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ String
"Expecting a datum after a comma"
        vectorFold (SAtom SchemeToken
TComma) (Datum
x : [Datum]
xs) = [Datum] -> Either String [Datum]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Datum] -> Either String [Datum])
-> [Datum] -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ Datum -> Datum
DComma Datum
x Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: [Datum]
xs
        vectorFold (SAtom SchemeToken
TCommaAt) [] = String -> Either String [Datum]
forall a b. a -> Either a b
Left (String -> Either String [Datum])
-> String -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ String
"Expecting a datum after a commaAt"
        vectorFold (SAtom SchemeToken
TCommaAt) (Datum
x : [Datum]
xs) = [Datum] -> Either String [Datum]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Datum] -> Either String [Datum])
-> [Datum] -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ Datum -> Datum
DCommaAt Datum
x Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: [Datum]
xs
        vectorFold (SAtom SchemeToken
TDot) [Datum]
_ = String -> Either String [Datum]
forall a b. a -> Either a b
Left String
"Unexpected dot"
        vectorFold (SList SExprType
STVector [SExpr SExprType SchemeToken]
xs) [Datum]
acc = ((:) (Datum -> [Datum] -> [Datum])
-> ([Datum] -> Datum) -> [Datum] -> [Datum] -> [Datum]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Datum] -> Datum
DVector) ([Datum] -> [Datum] -> [Datum])
-> Either String [Datum] -> Either String ([Datum] -> [Datum])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SExpr SExprType SchemeToken] -> Either String [Datum]
sexpr2Datum [SExpr SExprType SchemeToken]
xs Either String ([Datum] -> [Datum])
-> Either String [Datum] -> Either String [Datum]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Datum] -> Either String [Datum]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Datum]
acc
        vectorFold (SList SExprType
STList [SExpr SExprType SchemeToken]
xs) [Datum]
acc =
          let chooseConstructor :: (Bool, [Datum]) -> [Datum] -> [Datum]
chooseConstructor (Bool
isDotList, [Datum]
ls) = (:) (if Bool
isDotList
                                                       then [Datum] -> Datum -> Datum
DDotList ([Datum] -> [Datum]
forall a. [a] -> [a]
init [Datum]
ls) ([Datum] -> Datum
forall a. [a] -> a
last [Datum]
ls)
                                                       else [Datum] -> Datum
DList [Datum]
ls)
          in (Bool, [Datum]) -> [Datum] -> [Datum]
chooseConstructor ((Bool, [Datum]) -> [Datum] -> [Datum])
-> Either String (Bool, [Datum])
-> Either String ([Datum] -> [Datum])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SExpr SExprType SchemeToken
 -> (Bool, [Datum]) -> Either String (Bool, [Datum]))
-> (Bool, [Datum])
-> [SExpr SExprType SchemeToken]
-> Either String (Bool, [Datum])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM SExpr SExprType SchemeToken
-> (Bool, [Datum]) -> Either String (Bool, [Datum])
listFold (Bool
False, []) [SExpr SExprType SchemeToken]
xs) Either String ([Datum] -> [Datum])
-> Either String [Datum] -> Either String [Datum]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Datum] -> Either String [Datum]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Datum]
acc
        vectorFold (SAtom SchemeToken
x) [Datum]
acc = [Datum] -> Either String [Datum]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Datum] -> Either String [Datum])
-> [Datum] -> Either String [Datum]
forall a b. (a -> b) -> a -> b
$ SchemeToken -> Datum
simpleToken SchemeToken
x Datum -> [Datum] -> [Datum]
forall a. a -> [a] -> [a]
: [Datum]
acc

        simpleToken :: SchemeToken -> Datum
        simpleToken :: SchemeToken -> Datum
simpleToken (TBoolean Bool
x) = Bool -> Datum
DBoolean Bool
x
        simpleToken (TNumber SchemeNumber
x) = SchemeNumber -> Datum
DNumber SchemeNumber
x
        simpleToken (TChar Char
x) = Char -> Datum
DChar Char
x
        simpleToken (TString Text
x) = Text -> Datum
DString Text
x
        simpleToken (TIdentifier Text
x) = Text -> Datum
DIdentifier Text
x
        simpleToken SchemeToken
_ = String -> Datum
forall a. HasCallStack => String -> a
error String
"simpleToken only handles a subset of SchemeToken constructors"

        listFold :: SExpr SExprType SchemeToken -> (Bool, [Datum]) -> Either String (Bool, [Datum])
        listFold :: SExpr SExprType SchemeToken
-> (Bool, [Datum]) -> Either String (Bool, [Datum])
listFold (SAtom SchemeToken
TDot) (Bool
_, [Datum
x]) = (Bool, [Datum]) -> Either String (Bool, [Datum])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, [Datum
x])
        listFold SExpr SExprType SchemeToken
x (Bool
d, [Datum]
acc) = (,) Bool
d ([Datum] -> (Bool, [Datum]))
-> Either String [Datum] -> Either String (Bool, [Datum])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr SExprType SchemeToken -> [Datum] -> Either String [Datum]
vectorFold SExpr SExprType SchemeToken
x [Datum]
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 ()
whitespace :: m ()
whitespace = (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
' ' m Char -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'\t' m Char -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             (m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol m (Tokens s) -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: m ()
comment = Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
';' m Char -> m (Tokens s) -> m (Tokens s)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (\Token s
c -> Char
Token s
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
Token s
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') m (Tokens s) -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          ((m (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol m (Tokens s) -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

atmosphere :: (MonadParsec e s m, Token s ~ Char) => m ()
atmosphere :: m ()
atmosphere = m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
whitespace m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
comment

-- | The 'interTokenSpace' parser parses zero or more whitespace or comment.
interTokenSpace :: (MonadParsec e s m, Token s ~ Char) => m ()
interTokenSpace :: m ()
interTokenSpace = m () -> m [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
atmosphere m [()] -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | The 'interTokenSpace1' parser parses one or more whitespace or comment.
interTokenSpace1 :: (MonadParsec e s m, Token s ~ Char) => m ()
interTokenSpace1 :: m ()
interTokenSpace1 = m () -> m [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
atmosphere m [()] -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: m Text
identifier = m Text
standardIdentifier m Text -> m Text -> m Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Text
peculiarIdentifier
  where standardIdentifier :: m Text
standardIdentifier = do
          Char
i <- [Token s] -> m (Token s)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf String
[Token s]
initialList
          Tokens s
is <- Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (\Token s
c -> Char
Token s
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
subsequentList)
          Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Char
i Char -> ShowS
forall a. a -> [a] -> [a]
: Proxy s -> Tokens s -> [Token s]
forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) Tokens s
is)

initialList :: String
initialList :: String
initialList = [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"!$%&*/:<=>?^_~"

subsequentList :: String
subsequentList :: String
subsequentList = String
initialList String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"+-.@"

peculiarIdentifier :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m T.Text
peculiarIdentifier :: m Text
peculiarIdentifier = (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'+' m Char -> m Text -> m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"+") m Text -> m Text -> m Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                     (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'-' m Char -> m Text -> m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"-") m Text -> m Text -> m Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                     (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"...") m (Tokens s) -> m Text -> m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"...")

------------------------- 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 :: m Bool
boolean = (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#t") m (Tokens s) -> m Bool -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) m Bool -> m Bool -> m Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#f") m (Tokens s) -> m Bool -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: m Char
character = do
  Tokens s
_ <- Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#\\")
  (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"newline") m (Tokens s) -> m Char -> m Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n') m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
   (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"space") m (Tokens s) -> m Char -> m Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
' ') m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
   m Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
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 :: m Text
stringParser = do
  Char
_ <- Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'"'
  Builder
xs <- m Builder
(MonadParsec e s m, Token s ~ Char) => m Builder
consume
  Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
L.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
B.toLazyText Builder
xs

  where consume :: (MonadParsec e s m, Token s ~ Char) => m B.Builder
        consume :: m Builder
consume = do
          Tokens s
x <- Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (\Token s
c -> Char
Token s
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
Token s
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"')
          Char
c <- Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'\\' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'"'
          let xB :: Builder
xB = String -> Builder
B.fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ Proxy s -> Tokens s -> [Token s]
forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) Tokens s
x
          case Char
c of
            Char
'"' -> Builder -> m Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> m Builder) -> Builder -> m Builder
forall a b. (a -> b) -> a -> b
$ Builder
xB
            Char
_ -> do
               Char
c1 <- Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'\\' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'"'
               Builder
x2 <- m Builder
(MonadParsec e s m, Token s ~ Char) => m Builder
consume
               Builder -> m Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> m Builder) -> Builder -> m Builder
forall a b. (a -> b) -> a -> b
$ Builder
xB Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
B.fromString [Char
c1] Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
x2


------------------------- Numbers -------------------------
data Radix = R2 | R8 | R10 | R16
           deriving (Radix -> Radix -> Bool
(Radix -> Radix -> Bool) -> (Radix -> Radix -> Bool) -> Eq Radix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Radix -> Radix -> Bool
$c/= :: Radix -> Radix -> Bool
== :: Radix -> Radix -> Bool
$c== :: Radix -> Radix -> Bool
Eq, Int -> Radix -> ShowS
[Radix] -> ShowS
Radix -> String
(Int -> Radix -> ShowS)
-> (Radix -> String) -> ([Radix] -> ShowS) -> Show Radix
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Radix] -> ShowS
$cshowList :: [Radix] -> ShowS
show :: Radix -> String
$cshow :: Radix -> String
showsPrec :: Int -> Radix -> ShowS
$cshowsPrec :: Int -> Radix -> ShowS
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 (Exactness -> Exactness -> Bool
(Exactness -> Exactness -> Bool)
-> (Exactness -> Exactness -> Bool) -> Eq Exactness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exactness -> Exactness -> Bool
$c/= :: Exactness -> Exactness -> Bool
== :: Exactness -> Exactness -> Bool
$c== :: Exactness -> Exactness -> Bool
Eq, Int -> Exactness -> ShowS
[Exactness] -> ShowS
Exactness -> String
(Int -> Exactness -> ShowS)
-> (Exactness -> String)
-> ([Exactness] -> ShowS)
-> Show Exactness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exactness] -> ShowS
$cshowList :: [Exactness] -> ShowS
show :: Exactness -> String
$cshow :: Exactness -> String
showsPrec :: Int -> Exactness -> ShowS
$cshowsPrec :: Int -> Exactness -> ShowS
Show)

-- | The 'Sign' datatype indicates if a number is positive ('Plus') or negative ('Minus')
data Sign = Plus | Minus
          deriving (Sign -> Sign -> Bool
(Sign -> Sign -> Bool) -> (Sign -> Sign -> Bool) -> Eq Sign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sign -> Sign -> Bool
$c/= :: Sign -> Sign -> Bool
== :: Sign -> Sign -> Bool
$c== :: Sign -> Sign -> Bool
Eq, Int -> Sign -> ShowS
[Sign] -> ShowS
Sign -> String
(Int -> Sign -> ShowS)
-> (Sign -> String) -> ([Sign] -> ShowS) -> Show Sign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sign] -> ShowS
$cshowList :: [Sign] -> ShowS
show :: Sign -> String
$cshow :: Sign -> String
showsPrec :: Int -> Sign -> ShowS
$cshowsPrec :: Int -> Sign -> ShowS
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 (UInteger -> UInteger -> Bool
(UInteger -> UInteger -> Bool)
-> (UInteger -> UInteger -> Bool) -> Eq UInteger
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UInteger -> UInteger -> Bool
$c/= :: UInteger -> UInteger -> Bool
== :: UInteger -> UInteger -> Bool
$c== :: UInteger -> UInteger -> Bool
Eq, Int -> UInteger -> ShowS
[UInteger] -> ShowS
UInteger -> String
(Int -> UInteger -> ShowS)
-> (UInteger -> String) -> ([UInteger] -> ShowS) -> Show UInteger
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UInteger] -> ShowS
$cshowList :: [UInteger] -> ShowS
show :: UInteger -> String
$cshow :: UInteger -> String
showsPrec :: Int -> UInteger -> ShowS
$cshowsPrec :: Int -> UInteger -> ShowS
Show)

hasPounds :: UInteger -> Bool
hasPounds :: UInteger -> Bool
hasPounds (UInteger Integer
_) = Bool
False
hasPounds UInteger
_ = Bool
True

isInexactI :: UInteger -> Bool
isInexactI :: UInteger -> Bool
isInexactI = UInteger -> Bool
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 (Precision -> Precision -> Bool
(Precision -> Precision -> Bool)
-> (Precision -> Precision -> Bool) -> Eq Precision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Precision -> Precision -> Bool
$c/= :: Precision -> Precision -> Bool
== :: Precision -> Precision -> Bool
$c== :: Precision -> Precision -> Bool
Eq, Int -> Precision -> ShowS
[Precision] -> ShowS
Precision -> String
(Int -> Precision -> ShowS)
-> (Precision -> String)
-> ([Precision] -> ShowS)
-> Show Precision
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Precision] -> ShowS
$cshowList :: [Precision] -> ShowS
show :: Precision -> String
$cshow :: Precision -> String
showsPrec :: Int -> Precision -> ShowS
$cshowsPrec :: Int -> Precision -> ShowS
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 (Suffix -> Suffix -> Bool
(Suffix -> Suffix -> Bool)
-> (Suffix -> Suffix -> Bool) -> Eq Suffix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Suffix -> Suffix -> Bool
$c/= :: Suffix -> Suffix -> Bool
== :: Suffix -> Suffix -> Bool
$c== :: Suffix -> Suffix -> Bool
Eq, Int -> Suffix -> ShowS
[Suffix] -> ShowS
Suffix -> String
(Int -> Suffix -> ShowS)
-> (Suffix -> String) -> ([Suffix] -> ShowS) -> Show Suffix
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Suffix] -> ShowS
$cshowList :: [Suffix] -> ShowS
show :: Suffix -> String
$cshow :: Suffix -> String
showsPrec :: Int -> Suffix -> ShowS
$cshowsPrec :: Int -> Suffix -> ShowS
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 (SReal -> SReal -> Bool
(SReal -> SReal -> Bool) -> (SReal -> SReal -> Bool) -> Eq SReal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SReal -> SReal -> Bool
$c/= :: SReal -> SReal -> Bool
== :: SReal -> SReal -> Bool
$c== :: SReal -> SReal -> Bool
Eq, Int -> SReal -> ShowS
[SReal] -> ShowS
SReal -> String
(Int -> SReal -> ShowS)
-> (SReal -> String) -> ([SReal] -> ShowS) -> Show SReal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SReal] -> ShowS
$cshowList :: [SReal] -> ShowS
show :: SReal -> String
$cshow :: SReal -> String
showsPrec :: Int -> SReal -> ShowS
$cshowsPrec :: Int -> SReal -> ShowS
Show)

isInexactR :: SReal -> Bool
isInexactR :: SReal -> Bool
isInexactR (SInteger Sign
_ UInteger
i) = UInteger -> Bool
isInexactI UInteger
i
isInexactR (SRational Sign
_ UInteger
i1 UInteger
i2) = UInteger -> Bool
isInexactI UInteger
i1 Bool -> Bool -> Bool
|| UInteger -> Bool
isInexactI UInteger
i2
isInexactR (SDecimal Sign
_ UInteger
_ UInteger
_ Maybe Suffix
_) = Bool
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 (Complex -> Complex -> Bool
(Complex -> Complex -> Bool)
-> (Complex -> Complex -> Bool) -> Eq Complex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Complex -> Complex -> Bool
$c/= :: Complex -> Complex -> Bool
== :: Complex -> Complex -> Bool
$c== :: Complex -> Complex -> Bool
Eq, Int -> Complex -> ShowS
[Complex] -> ShowS
Complex -> String
(Int -> Complex -> ShowS)
-> (Complex -> String) -> ([Complex] -> ShowS) -> Show Complex
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Complex] -> ShowS
$cshowList :: [Complex] -> ShowS
show :: Complex -> String
$cshow :: Complex -> String
showsPrec :: Int -> Complex -> ShowS
$cshowsPrec :: Int -> Complex -> ShowS
Show)

isInexact :: Complex -> Bool
isInexact :: Complex -> Bool
isInexact (CReal SReal
s) = SReal -> Bool
isInexactR SReal
s
isInexact (CAngle SReal
s1 SReal
s2) = SReal -> Bool
isInexactR SReal
s1 Bool -> Bool -> Bool
|| SReal -> Bool
isInexactR SReal
s2
isInexact (CAbsolute SReal
s1 SReal
s2) = SReal -> Bool
isInexactR SReal
s1 Bool -> Bool -> Bool
|| SReal -> Bool
isInexactR SReal
s2

-- | A Scheme R5RS number is an exact or inexact complex number.
data SchemeNumber = SchemeNumber Exactness Complex
                  deriving (SchemeNumber -> SchemeNumber -> Bool
(SchemeNumber -> SchemeNumber -> Bool)
-> (SchemeNumber -> SchemeNumber -> Bool) -> Eq SchemeNumber
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemeNumber -> SchemeNumber -> Bool
$c/= :: SchemeNumber -> SchemeNumber -> Bool
== :: SchemeNumber -> SchemeNumber -> Bool
$c== :: SchemeNumber -> SchemeNumber -> Bool
Eq, Int -> SchemeNumber -> ShowS
[SchemeNumber] -> ShowS
SchemeNumber -> String
(Int -> SchemeNumber -> ShowS)
-> (SchemeNumber -> String)
-> ([SchemeNumber] -> ShowS)
-> Show SchemeNumber
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemeNumber] -> ShowS
$cshowList :: [SchemeNumber] -> ShowS
show :: SchemeNumber -> String
$cshow :: SchemeNumber -> String
showsPrec :: Int -> SchemeNumber -> ShowS
$cshowsPrec :: Int -> SchemeNumber -> ShowS
Show)

-- | The 'number' parser parses a Scheme R5RS number.
number :: (MonadParsec e s m, Token s ~ Char) => m SchemeNumber
number :: m SchemeNumber
number = do
  (Maybe Radix
r, Maybe Exactness
e) <- m (Maybe Radix, Maybe Exactness)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Maybe Radix, Maybe Exactness)
prefix
  Complex
c <- Radix -> m Complex
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> m Complex
complex (Radix -> Maybe Radix -> Radix
forall a. a -> Maybe a -> a
fromMaybe Radix
R10 Maybe Radix
r)
  let e' :: Exactness
e' = Exactness -> Maybe Exactness -> Exactness
forall a. a -> Maybe a -> a
fromMaybe (if Complex -> Bool
isInexact Complex
c then Exactness
Inexact else Exactness
Exact) Maybe Exactness
e
  SchemeNumber -> m SchemeNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemeNumber -> m SchemeNumber) -> SchemeNumber -> m SchemeNumber
forall a b. (a -> b) -> a -> b
$ Exactness -> Complex -> SchemeNumber
SchemeNumber Exactness
e'  Complex
c

complex :: forall e s m . (MonadParsec e s m, Token s ~ Char) => Radix -> m Complex
complex :: Radix -> m Complex
complex Radix
r = do
  Maybe Sign
ms <- m Sign -> m (Maybe Sign)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Sign
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Sign
sign
  case Maybe Sign
ms of
    Maybe Sign
Nothing -> Sign -> m Complex
complex' Sign
Plus
    Just Sign
s -> Sign -> m Complex
forall (m :: * -> *) e s.
(MonadParsec e s m, Token s ~ Char) =>
Sign -> m Complex
i Sign
s m Complex -> m Complex -> m Complex
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Sign -> m Complex
complex' Sign
s

  where
    -- Parser for +i and -i
    i :: Sign -> m Complex
i Sign
s = Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'i' m Char -> m Complex -> m Complex
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Complex -> m Complex
forall (m :: * -> *) a. Monad m => a -> m a
return (Complex -> m Complex) -> Complex -> m Complex
forall a b. (a -> b) -> a -> b
$ SReal -> SReal -> Complex
CAbsolute (Sign -> UInteger -> SReal
SInteger Sign
Plus (Integer -> UInteger
UInteger Integer
0)) (Sign -> UInteger -> SReal
SInteger Sign
s (Integer -> UInteger
UInteger Integer
1)))

    -- Parser for complex except +i and -i
    complex' :: Sign -> m Complex
complex' Sign
sr = do
      -- First parse a number
      SReal
n1 <- Radix -> Sign -> m SReal
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> Sign -> m SReal
ureal Radix
r Sign
sr
      -- Check if the number is followed by any of these characters
      Maybe Char
c <- m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'@' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'+' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'-' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'i')
      case Maybe Char
c of
          -- Plain real number
          Maybe Char
Nothing -> Complex -> m Complex
forall (m :: * -> *) a. Monad m => a -> m a
return (Complex -> m Complex) -> Complex -> m Complex
forall a b. (a -> b) -> a -> b
$ SReal -> Complex
CReal SReal
n1
          -- Complex angular number
          Just Char
'@' -> do
            SReal
n2 <- Radix -> m SReal
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> m SReal
real Radix
r
            Complex -> m Complex
forall (m :: * -> *) a. Monad m => a -> m a
return (Complex -> m Complex) -> Complex -> m Complex
forall a b. (a -> b) -> a -> b
$ SReal -> SReal -> Complex
CAngle SReal
n1 SReal
n2
          -- Pure imaginary number
          Just Char
'i' -> Complex -> m Complex
forall (m :: * -> *) a. Monad m => a -> m a
return (Complex -> m Complex) -> Complex -> m Complex
forall a b. (a -> b) -> a -> b
$ SReal -> SReal -> Complex
CAbsolute (Sign -> UInteger -> SReal
SInteger Sign
Plus (Integer -> UInteger
UInteger Integer
0)) SReal
n1
          -- Real +/- Imaginary number
          Just Char
'+' -> SReal -> Sign -> m Complex
imaginaryPart SReal
n1 Sign
Plus
          Just Char
_ -> SReal -> Sign -> m Complex
imaginaryPart SReal
n1 Sign
Minus

    imaginaryPart :: SReal -> Sign -> m Complex
imaginaryPart SReal
realN Sign
si = do
      Maybe SReal
u <- m SReal -> m (Maybe SReal)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Radix -> Sign -> m SReal
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> Sign -> m SReal
ureal Radix
r Sign
si)
      Char
_ <- Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'i'
      case Maybe SReal
u of
        Maybe SReal
Nothing -> Complex -> m Complex
forall (m :: * -> *) a. Monad m => a -> m a
return (Complex -> m Complex) -> Complex -> m Complex
forall a b. (a -> b) -> a -> b
$ SReal -> SReal -> Complex
CAbsolute SReal
realN (Sign -> UInteger -> SReal
SInteger Sign
si (Integer -> UInteger
UInteger Integer
1))
        Just SReal
n2 -> Complex -> m Complex
forall (m :: * -> *) a. Monad m => a -> m a
return (Complex -> m Complex) -> Complex -> m Complex
forall a b. (a -> b) -> a -> b
$ SReal -> SReal -> Complex
CAbsolute SReal
realN SReal
n2

real :: (MonadParsec e s m, Token s ~ Char) => Radix -> m SReal
real :: Radix -> m SReal
real Radix
r = do
  Sign
s <- Sign -> m Sign -> m Sign
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Sign
Plus m Sign
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Sign
sign
  Radix -> Sign -> m SReal
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> Sign -> m SReal
ureal Radix
r Sign
s

ureal :: forall e s m . (MonadParsec e s m, Token s ~ Char) => Radix -> Sign -> m SReal
ureal :: Radix -> Sign -> m SReal
ureal Radix
r Sign
s = m SReal
dotN m SReal -> m SReal -> m SReal
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m SReal
ureal'

  where dotN :: m SReal
dotN =  do
          Char
_ <- Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'.'
          if Radix
r Radix -> Radix -> Bool
forall a. Eq a => a -> a -> Bool
/= Radix
R10
          then String -> m SReal -> m SReal
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"Numbers containing decimal point must be in decimal radix" m SReal
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          else do
             UInteger
n <- Radix -> m UInteger
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> m UInteger
uinteger Radix
R10
             Maybe Suffix
sf <- m Suffix -> m (Maybe Suffix)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Suffix
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Suffix
suffix
             SReal -> m SReal
forall (m :: * -> *) a. Monad m => a -> m a
return (SReal -> m SReal) -> SReal -> m SReal
forall a b. (a -> b) -> a -> b
$ Sign -> UInteger -> UInteger -> Maybe Suffix -> SReal
SDecimal Sign
s (Integer -> UInteger
UInteger Integer
0) UInteger
n Maybe Suffix
sf

        ureal' :: m SReal
ureal' = do
          -- First parse an integer
          UInteger
u1 <- Radix -> m UInteger
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> m UInteger
uinteger Radix
r
          -- Check if the integer is followed by these characters
          Maybe Char
mc <- m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'/' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'.')
          case Maybe Char
mc of
            -- Integer with or without suffix
            Maybe Char
Nothing -> UInteger -> m SReal
plainInteger UInteger
u1
            -- Rational
            Just Char
'/' -> UInteger -> m SReal
rational UInteger
u1
            -- Decimal
            Just Char
_ -> UInteger -> m SReal
decimal UInteger
u1

        plainInteger :: UInteger -> m SReal
plainInteger UInteger
u1 = do
            Maybe Suffix
sf <- m Suffix -> m (Maybe Suffix)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Suffix
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Suffix
suffix
            case Maybe Suffix
sf of
              Just Suffix
_ -> SReal -> m SReal
forall (m :: * -> *) a. Monad m => a -> m a
return (SReal -> m SReal) -> SReal -> m SReal
forall a b. (a -> b) -> a -> b
$ Sign -> UInteger -> UInteger -> Maybe Suffix -> SReal
SDecimal Sign
s UInteger
u1 (Integer -> UInteger
UInteger Integer
0) Maybe Suffix
sf
              Maybe Suffix
Nothing -> SReal -> m SReal
forall (m :: * -> *) a. Monad m => a -> m a
return (SReal -> m SReal) -> SReal -> m SReal
forall a b. (a -> b) -> a -> b
$ Sign -> UInteger -> SReal
SInteger Sign
s UInteger
u1

        rational :: UInteger -> m SReal
rational UInteger
u1 = do
          UInteger
u2 <- Radix -> m UInteger
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Radix -> m UInteger
uinteger Radix
r
          SReal -> m SReal
forall (m :: * -> *) a. Monad m => a -> m a
return (SReal -> m SReal) -> SReal -> m SReal
forall a b. (a -> b) -> a -> b
$ Sign -> UInteger -> UInteger -> SReal
SRational Sign
s UInteger
u1 UInteger
u2

        decimal :: UInteger -> m SReal
decimal UInteger
u1 = do
          if Radix
r Radix -> Radix -> Bool
forall a. Eq a => a -> a -> Bool
/= Radix
R10
          then String -> m SReal -> m SReal
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"Numbers containing decimal point must be in decimal radix" m SReal
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          else do
             -- If u1 has # character, only other # are
             -- allowed. Otherwise a number may be present
             Maybe Integer
n <- if UInteger -> Bool
hasPounds UInteger
u1 then Maybe Integer -> m (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing else m Integer -> m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Radix -> m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Integral a) =>
Radix -> m a
udigit Radix
R10) :: m (Maybe Integer)
             Tokens s
pounds <- Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')
             Maybe Suffix
sf <- m Suffix -> m (Maybe Suffix)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Suffix
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Suffix
suffix
             let nbPounds :: Integer
nbPounds = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Proxy s -> Tokens s -> Int
forall s. Stream s => Proxy s -> Tokens s -> Int
chunkLength (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) Tokens s
pounds
             let u2 :: UInteger
u2 = case (UInteger -> Bool
hasPounds UInteger
u1, Integer
nbPounds, Maybe Integer
n) of
                         (Bool
True, Integer
p, Maybe Integer
_) -> Integer -> UInteger
UPounds Integer
p
                         (Bool
False, Integer
0, Maybe Integer
Nothing) -> Integer -> UInteger
UInteger Integer
0
                         (Bool
False, Integer
0, (Just Integer
x)) -> Integer -> UInteger
UInteger Integer
x
                         (Bool
False, Integer
p, Maybe Integer
Nothing) -> Integer -> UInteger
UPounds Integer
p
                         (Bool
False, Integer
p, (Just Integer
x)) -> Integer -> Integer -> UInteger
UIntPounds Integer
x Integer
p
             SReal -> m SReal
forall (m :: * -> *) a. Monad m => a -> m a
return (SReal -> m SReal) -> SReal -> m SReal
forall a b. (a -> b) -> a -> b
$ Sign -> UInteger -> UInteger -> Maybe Suffix -> SReal
SDecimal Sign
s UInteger
u1 UInteger
u2 Maybe Suffix
sf

uinteger :: forall e s m . (MonadParsec e s m, Token s ~ Char) => Radix -> m UInteger
uinteger :: Radix -> m UInteger
uinteger Radix
r = do
  Integer
n <- Radix -> m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Integral a) =>
Radix -> m a
udigit Radix
r
  Tokens s
pounds <- Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')
  let nbPounds :: Integer
nbPounds = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Proxy s -> Tokens s -> Int
forall s. Stream s => Proxy s -> Tokens s -> Int
chunkLength (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) Tokens s
pounds
  if Integer
nbPounds Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
  then UInteger -> m UInteger
forall (m :: * -> *) a. Monad m => a -> m a
return (UInteger -> m UInteger) -> UInteger -> m UInteger
forall a b. (a -> b) -> a -> b
$ Integer -> UInteger
UInteger Integer
n
  else UInteger -> m UInteger
forall (m :: * -> *) a. Monad m => a -> m a
return (UInteger -> m UInteger) -> UInteger -> m UInteger
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> UInteger
UIntPounds Integer
n Integer
nbPounds


prefix :: (MonadParsec e s m, Token s ~ Char) => m (Maybe Radix, Maybe Exactness)
prefix :: m (Maybe Radix, Maybe Exactness)
prefix = do
  Maybe Char
x <- m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m Char -> m (Maybe Char)) -> m Char -> m (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'#'
  case Maybe Char
x of
    Maybe Char
Nothing -> (Maybe Radix, Maybe Exactness) -> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Radix
forall a. Maybe a
Nothing, Maybe Exactness
forall a. Maybe a
Nothing)
    Maybe Char
_ -> do
      Char
c <- Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'i' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'e' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'b' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
           Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'o' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'd' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'x'
      case Char
c of
        Char
'i' -> m Radix -> m (Maybe Radix)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Radix
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Radix
radix m (Maybe Radix)
-> (Maybe Radix -> m (Maybe Radix, Maybe Exactness))
-> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Radix
r -> (Maybe Radix, Maybe Exactness) -> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Radix
r, Exactness -> Maybe Exactness
forall a. a -> Maybe a
Just Exactness
Inexact)
        Char
'e' -> m Radix -> m (Maybe Radix)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Radix
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Radix
radix m (Maybe Radix)
-> (Maybe Radix -> m (Maybe Radix, Maybe Exactness))
-> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Radix
r -> (Maybe Radix, Maybe Exactness) -> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Radix
r, Exactness -> Maybe Exactness
forall a. a -> Maybe a
Just Exactness
Exact)
        Char
'b' -> m Exactness -> m (Maybe Exactness)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Exactness
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Exactness
exactness m (Maybe Exactness)
-> (Maybe Exactness -> m (Maybe Radix, Maybe Exactness))
-> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Exactness
e -> (Maybe Radix, Maybe Exactness) -> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a. Monad m => a -> m a
return (Radix -> Maybe Radix
forall a. a -> Maybe a
Just Radix
R2, Maybe Exactness
e)
        Char
'o' -> m Exactness -> m (Maybe Exactness)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Exactness
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Exactness
exactness m (Maybe Exactness)
-> (Maybe Exactness -> m (Maybe Radix, Maybe Exactness))
-> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Exactness
e -> (Maybe Radix, Maybe Exactness) -> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a. Monad m => a -> m a
return (Radix -> Maybe Radix
forall a. a -> Maybe a
Just Radix
R8, Maybe Exactness
e)
        Char
'd' -> m Exactness -> m (Maybe Exactness)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Exactness
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Exactness
exactness m (Maybe Exactness)
-> (Maybe Exactness -> m (Maybe Radix, Maybe Exactness))
-> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Exactness
e -> (Maybe Radix, Maybe Exactness) -> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a. Monad m => a -> m a
return (Radix -> Maybe Radix
forall a. a -> Maybe a
Just Radix
R10, Maybe Exactness
e)
        Char
_ -> m Exactness -> m (Maybe Exactness)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Exactness
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Exactness
exactness m (Maybe Exactness)
-> (Maybe Exactness -> m (Maybe Radix, Maybe Exactness))
-> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Exactness
e -> (Maybe Radix, Maybe Exactness) -> m (Maybe Radix, Maybe Exactness)
forall (m :: * -> *) a. Monad m => a -> m a
return (Radix -> Maybe Radix
forall a. a -> Maybe a
Just Radix
R16, Maybe Exactness
e)

exactness :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m Exactness
exactness :: m Exactness
exactness = (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#e") m (Tokens s) -> m Exactness -> m Exactness
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exactness -> m Exactness
forall (m :: * -> *) a. Monad m => a -> m a
return Exactness
Exact) m Exactness -> m Exactness -> m Exactness
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
            (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#i") m (Tokens s) -> m Exactness -> m Exactness
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exactness -> m Exactness
forall (m :: * -> *) a. Monad m => a -> m a
return Exactness
Inexact)

radix :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m  Radix
radix :: m Radix
radix =
  (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#b") m (Tokens s) -> m Radix -> m Radix
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Radix -> m Radix
forall (m :: * -> *) a. Monad m => a -> m a
return Radix
R2) m Radix -> m Radix -> m Radix
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#o") m (Tokens s) -> m Radix -> m Radix
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Radix -> m Radix
forall (m :: * -> *) a. Monad m => a -> m a
return Radix
R8) m Radix -> m Radix -> m Radix
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#d") m (Tokens s) -> m Radix -> m Radix
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Radix -> m Radix
forall (m :: * -> *) a. Monad m => a -> m a
return Radix
R10) m Radix -> m Radix -> m Radix
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
"#x") m (Tokens s) -> m Radix -> m Radix
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Radix -> m Radix
forall (m :: * -> *) a. Monad m => a -> m a
return Radix
R16)

udigit :: forall e s m a . (MonadParsec e s m, Token s ~ Char, Integral a) => Radix -> m a
udigit :: Radix -> m a
udigit Radix
r = do
  case Radix
r of
    Radix
R2 -> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
ML.binary
    Radix
R8 -> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
ML.octal
    Radix
R10 -> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
ML.decimal
    Radix
R16 -> m a
hexadecimal -- ML.hexadecimal also parses uppercase "ABCDEF"
  where hexadecimal :: m a
hexadecimal = Tokens s -> a
mkNum
                      (Tokens s -> a) -> m (Tokens s) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token s
c -> Char
Token s
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789abcdef" :: String))
                      m a -> String -> m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"hexadecimal integer"

        mkNum :: Tokens s -> a
mkNum    = (a -> Char -> a) -> a -> String -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> Char -> a
forall a. Num a => a -> Char -> a
step a
0 (String -> a) -> (Tokens s -> String) -> Tokens s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> Tokens s -> [Token s]
forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s)
        step :: a -> Char -> a
step a
a Char
c = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
16 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
C.digitToInt Char
c)

sign :: (MonadParsec e s m, Token s ~ Char) => m  Sign
sign :: m Sign
sign = (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'-' m Char -> m Sign -> m Sign
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Sign -> m Sign
forall (m :: * -> *) a. Monad m => a -> m a
return Sign
Minus) m Sign -> m Sign -> m Sign
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'+' m Char -> m Sign -> m Sign
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Sign -> m Sign
forall (m :: * -> *) a. Monad m => a -> m a
return Sign
Plus)

suffix :: (MonadParsec e s m, Token s ~ Char) => m Suffix
suffix :: m Suffix
suffix = do
  Precision
p <- (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'e' m Char -> m Precision -> m Precision
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Precision -> m Precision
forall (m :: * -> *) a. Monad m => a -> m a
return Precision
PDefault)  m Precision -> m Precision -> m Precision
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
's' m Char -> m Precision -> m Precision
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Precision -> m Precision
forall (m :: * -> *) a. Monad m => a -> m a
return Precision
PShort)  m Precision -> m Precision -> m Precision
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'f' m Char -> m Precision -> m Precision
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Precision -> m Precision
forall (m :: * -> *) a. Monad m => a -> m a
return Precision
PSingle) m Precision -> m Precision -> m Precision
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'd' m Char -> m Precision -> m Precision
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Precision -> m Precision
forall (m :: * -> *) a. Monad m => a -> m a
return Precision
PDouble) m Precision -> m Precision -> m Precision
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'l' m Char -> m Precision -> m Precision
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Precision -> m Precision
forall (m :: * -> *) a. Monad m => a -> m a
return Precision
PLong)
  Sign
s <- Sign -> m Sign -> m Sign
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Sign
Plus m Sign
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Sign
sign
  Integer
n <- Radix -> m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Integral a) =>
Radix -> m a
udigit Radix
R10
  Suffix -> m Suffix
forall (m :: * -> *) a. Monad m => a -> m a
return (Suffix -> m Suffix) -> Suffix -> m Suffix
forall a b. (a -> b) -> a -> b
$ Precision -> Sign -> Integer -> Suffix
Suffix Precision
p Sign
s Integer
n

------------------------- Other tokens -------------------------
-- | The 'quote' parser parses a quote character (').
quote :: (MonadParsec e s m, Token s ~ Char) => m Char
quote :: m Char
quote = Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'\''

-- | The 'quasiquote' parser parses a quasiquote character (`).
quasiquote :: (MonadParsec e s m, Token s ~ Char) => m Char
quasiquote :: m Char
quasiquote = Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'`'

-- | The 'comma' parser parses a comma (,).
comma :: (MonadParsec e s m, Token s ~ Char) => m Char
comma :: m Char
comma = Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
','

-- | The 'commaAt' parser parses a comma followed by \@ (,\@).
commaAt :: forall e s m . (MonadParsec e s m, Token s ~ Char) => m T.Text
commaAt :: m Text
commaAt = Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk (Proxy s -> [Token s] -> Tokens s
forall s. Stream s => Proxy s -> [Token s] -> Tokens s
tokensToChunk (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) [Token s]
",@") m (Tokens s) -> m Text -> m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
",@"

-- | The 'dot' parser parses a single dot character (.).
dot :: (MonadParsec e s m, Token s ~ Char) => m Char
dot :: m Char
dot = Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'.'