{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{- |
Module      : Language.Scheme.Parser
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : portable

This module implements parsing of Scheme code.
-}

module Language.Scheme.Parser 
    (
      lispDef
    -- *Higher level parsing
    , mainParser
    , readOrThrow
    , readExpr
    , readExprList 
    -- *Low level parsing
    , parseExpr 
    , parseAtom
    , parseBool
    , parseChar
    , parseOctalNumber 
    , parseBinaryNumber
    , parseHexNumber
    , parseDecimalNumber
    , parseNumber 
    , parseRealNumber
    , parseRationalNumber 
    , parseComplexNumber 
    , parseEscapedChar 
    , parseString 
    , parseVector
    , parseByteVector
    , parseHashTable
    , parseList
    , parseDottedList
    , parseQuoted
    , parseQuasiQuoted 
    , parseUnquoted 
    , parseUnquoteSpliced 
    ) where
import Language.Scheme.Types
import Control.Monad.Except
import Data.Array
import qualified Data.ByteString as BS
import qualified Data.Char as DC
import Data.Complex
import qualified Data.Map
import Data.Ratio
import Data.Word
import Numeric
import Text.ParserCombinators.Parsec hiding (spaces)
import Text.Parsec.Language
import qualified Text.Parsec.Token as P
#if __GLASGOW_HASKELL__ >= 702
import Data.Functor.Identity (Identity)
import Text.Parsec.Prim (ParsecT)
#endif

-- This was added by pull request #63 as part of a series of fixes
-- to get husk to build on ghc 7.2.2
--
-- For now this has been removed to allow husk to support the older
-- GHC 6.x.x series.
--
--import Data.Functor.Identity (Identity)

-- |Language definition for Scheme
lispDef :: LanguageDef ()
lispDef :: LanguageDef ()
lispDef 
  = LanguageDef ()
forall st. LanguageDef st
emptyDef    
  { commentStart :: String
P.commentStart   = String
"#|"
  , commentEnd :: String
P.commentEnd     = String
"|#"
  , commentLine :: String
P.commentLine    = String
";"
  , nestedComments :: Bool
P.nestedComments = Bool
True
  , identStart :: ParsecT String () Identity Char
P.identStart     = ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
symbol
  , identLetter :: ParsecT String () Identity Char
P.identLetter    = ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
symbol
  , reservedNames :: [String]
P.reservedNames  = []
  , caseSensitive :: Bool
P.caseSensitive  = Bool
True
  } 

#if __GLASGOW_HASKELL__ >= 702
lexer :: P.GenTokenParser String () Data.Functor.Identity.Identity
#endif
lexer :: GenTokenParser String () Identity
lexer = LanguageDef () -> GenTokenParser String () Identity
forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
P.makeTokenParser LanguageDef ()
lispDef

#if __GLASGOW_HASKELL__ >= 702
dot :: ParsecT String () Identity String
#endif
dot :: ParsecT String () Identity String
dot = GenTokenParser String () Identity
-> ParsecT String () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.dot GenTokenParser String () Identity
lexer

#if __GLASGOW_HASKELL__ >= 702
parens :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
parens :: ParsecT String () Identity a -> ParsecT String () Identity a
parens = GenTokenParser String () Identity
-> forall a.
   ParsecT String () Identity a -> ParsecT String () Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
P.parens GenTokenParser String () Identity
lexer

#if __GLASGOW_HASKELL__ >= 702
brackets :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
brackets :: ParsecT String () Identity a -> ParsecT String () Identity a
brackets = GenTokenParser String () Identity
-> forall a.
   ParsecT String () Identity a -> ParsecT String () Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
P.brackets GenTokenParser String () Identity
lexer

#if __GLASGOW_HASKELL__ >= 702
identifier :: ParsecT String () Identity String
#endif
identifier :: ParsecT String () Identity String
identifier = GenTokenParser String () Identity
-> ParsecT String () Identity String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
P.identifier GenTokenParser String () Identity
lexer

#if __GLASGOW_HASKELL__ >= 702
whiteSpace :: ParsecT String () Identity ()
#endif
whiteSpace :: ParsecT String () Identity ()
whiteSpace = GenTokenParser String () Identity -> ParsecT String () Identity ()
forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
P.whiteSpace GenTokenParser String () Identity
lexer

#if __GLASGOW_HASKELL__ >= 702
lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a
lexeme = GenTokenParser String () Identity
-> forall a.
   ParsecT String () Identity a -> ParsecT String () Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
P.lexeme GenTokenParser String () Identity
lexer

-- |Match a special character
symbol :: Parser Char
symbol :: ParsecT String () Identity Char
symbol = String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"!$%&|*+-/:<=>?@^_~."

-- |Parse an atom (scheme symbol)
parseAtom :: Parser LispVal
parseAtom :: Parser LispVal
parseAtom = do
  String
atom <- ParsecT String () Identity String
identifier
  if String
atom String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"."
     then Parser LispVal
forall tok st a. GenParser tok st a
pzero -- Do not match this form
     else LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
atom

-- |Parse a boolean
parseBool :: Parser LispVal
parseBool :: Parser LispVal
parseBool = do String
_ <- String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#"
               Char
x <- String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"tf"
               LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ case Char
x of
                          Char
't' -> Bool -> LispVal
Bool Bool
True
                          Char
'f' -> Bool -> LispVal
Bool Bool
False
                          Char
_ -> Bool -> LispVal
Bool Bool
False

-- |Parse a character
parseChar :: Parser LispVal
parseChar :: Parser LispVal
parseChar = do
  String
_ <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#\\")
  Char
c <- ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
  String
r <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)
  let pchr :: String
pchr = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
r
  case String
pchr of
    String
"space"     -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
' '
    String
"newline"   -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\n'
    String
"alarm"     -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\a' 
    String
"backspace" -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\b' 
    String
"delete"    -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\DEL'
    String
"escape"    -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\ESC' 
    String
"null"      -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\0' 
    String
"return"    -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\n' 
    String
"tab"       -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
'\t'
    String
_ -> case (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
r) of
        [Char
ch] -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
ch
        (Char
'x' : String
hexs) -> do
            Char
rv <- String -> ParsecT String () Identity Char
forall st. String -> GenParser Char st Char
parseHexScalar String
hexs
            LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Char -> LispVal
Char Char
rv
        String
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero

-- |Parse an integer in octal notation, base 8
parseOctalNumber :: Parser LispVal
parseOctalNumber :: Parser LispVal
parseOctalNumber = do
  String
_ <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#o")
  String
sign <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-")
  String
num <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"01234567")
  case (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sign) of
     Int
0 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ (Integer, String) -> Integer
forall a b. (a, b) -> a
fst ((Integer, String) -> Integer) -> (Integer, String) -> Integer
forall a b. (a -> b) -> a -> b
$ [(Integer, String)] -> (Integer, String)
forall a. [a] -> a
head (ReadS Integer
forall a. (Eq a, Num a) => ReadS a
Numeric.readOct String
num)
     Int
1 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) (-Integer
1) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer, String) -> Integer
forall a b. (a, b) -> a
fst ((Integer, String) -> Integer) -> (Integer, String) -> Integer
forall a b. (a -> b) -> a -> b
$ [(Integer, String)] -> (Integer, String)
forall a. [a] -> a
head (ReadS Integer
forall a. (Eq a, Num a) => ReadS a
Numeric.readOct String
num)
     Int
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero

-- |Parse an integer in binary notation, base 2
parseBinaryNumber :: Parser LispVal
parseBinaryNumber :: Parser LispVal
parseBinaryNumber = do
  String
_ <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#b")
  String
sign <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-")
  String
num <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"01")
  case (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sign) of
     Int
0 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ (Integer, String) -> Integer
forall a b. (a, b) -> a
fst ((Integer, String) -> Integer) -> (Integer, String) -> Integer
forall a b. (a -> b) -> a -> b
$ [(Integer, String)] -> (Integer, String)
forall a. [a] -> a
head (Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
Numeric.readInt Integer
2 (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"01") Char -> Int
DC.digitToInt String
num)
     Int
1 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) (-Integer
1) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer, String) -> Integer
forall a b. (a, b) -> a
fst ((Integer, String) -> Integer) -> (Integer, String) -> Integer
forall a b. (a -> b) -> a -> b
$ [(Integer, String)] -> (Integer, String)
forall a. [a] -> a
head (Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
Numeric.readInt Integer
2 (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"01") Char -> Int
DC.digitToInt String
num)
     Int
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero

-- |Parse an integer in hexadecimal notation, base 16
parseHexNumber :: Parser LispVal
parseHexNumber :: Parser LispVal
parseHexNumber = do
  String
_ <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#x")
  String
sign <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-")
  String
num <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"abcdefABCDEF")
  case (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sign) of
     Int
0 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ (Integer, String) -> Integer
forall a b. (a, b) -> a
fst ((Integer, String) -> Integer) -> (Integer, String) -> Integer
forall a b. (a -> b) -> a -> b
$ [(Integer, String)] -> (Integer, String)
forall a. [a] -> a
head (ReadS Integer
forall a. (Eq a, Num a) => ReadS a
Numeric.readHex String
num)
     Int
1 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number (Integer -> LispVal) -> Integer -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) (-Integer
1) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer, String) -> Integer
forall a b. (a, b) -> a
fst ((Integer, String) -> Integer) -> (Integer, String) -> Integer
forall a b. (a -> b) -> a -> b
$ [(Integer, String)] -> (Integer, String)
forall a. [a] -> a
head (ReadS Integer
forall a. (Eq a, Num a) => ReadS a
Numeric.readHex String
num)
     Int
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero

-- |Parser for Integer, base 10
parseDecimalNumber :: Parser LispVal
parseDecimalNumber :: Parser LispVal
parseDecimalNumber = do
  [String]
_ <- GenParser Char () [String] -> GenParser Char () [String]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity String -> GenParser Char () [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#d"))
  String
sign <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-")
  String
num <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
  if (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sign) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
     then Parser LispVal
forall tok st a. GenParser tok st a
pzero
     else LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ (Integer -> LispVal
Number (Integer -> LispVal) -> (String -> Integer) -> String -> LispVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
forall a. Read a => String -> a
read) (String -> LispVal) -> String -> LispVal
forall a b. (a -> b) -> a -> b
$ String
sign String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
num

-- |Parser for a base 10 Integer that will also
--  check to see if the number is followed by
--  an exponent (scientific notation). If so,
--  the integer is converted to a float of the
--  given magnitude.
parseDecimalNumberMaybeExponent :: Parser LispVal
parseDecimalNumberMaybeExponent :: Parser LispVal
parseDecimalNumberMaybeExponent = do
  LispVal
num <- Parser LispVal
parseDecimalNumber
  LispVal -> Parser LispVal
parseNumberExponent LispVal
num

-- |Parse an integer in any base
parseNumber :: Parser LispVal
parseNumber :: Parser LispVal
parseNumber = Parser LispVal
parseDecimalNumberMaybeExponent Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
              Parser LispVal
parseHexNumber Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
              Parser LispVal
parseBinaryNumber Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
              Parser LispVal
parseOctalNumber Parser LispVal -> String -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?>
              String
"Unable to parse number"

-- |Parse a floating point number
parseRealNumber :: Parser LispVal
parseRealNumber :: Parser LispVal
parseRealNumber = do
  String
sign <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-+")
  String
num <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
  String
frac <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
  let dec :: String
dec = if Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
num)
               then String
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
frac
               else String
"0." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
frac
  LispVal
f <- case (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sign) of
     Int
0 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Double -> LispVal
Float (Double -> LispVal) -> Double -> LispVal
forall a b. (a -> b) -> a -> b
$ (Double, String) -> Double
forall a b. (a, b) -> a
fst ((Double, String) -> Double) -> (Double, String) -> Double
forall a b. (a -> b) -> a -> b
$ [(Double, String)] -> (Double, String)
forall a. [a] -> a
head (ReadS Double
forall a. RealFrac a => ReadS a
Numeric.readFloat String
dec)
          -- Bit of a hack, but need to support the + sign as well as the minus.
     Int
1 -> if String
sign String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-" 
             then LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Double -> LispVal
Float (Double -> LispVal) -> Double -> LispVal
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) (-Double
1.0) (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ (Double, String) -> Double
forall a b. (a, b) -> a
fst ((Double, String) -> Double) -> (Double, String) -> Double
forall a b. (a -> b) -> a -> b
$ [(Double, String)] -> (Double, String)
forall a. [a] -> a
head (ReadS Double
forall a. RealFrac a => ReadS a
Numeric.readFloat String
dec)
             else LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Double -> LispVal
Float (Double -> LispVal) -> Double -> LispVal
forall a b. (a -> b) -> a -> b
$ (Double, String) -> Double
forall a b. (a, b) -> a
fst ((Double, String) -> Double) -> (Double, String) -> Double
forall a b. (a -> b) -> a -> b
$ [(Double, String)] -> (Double, String)
forall a. [a] -> a
head (ReadS Double
forall a. RealFrac a => ReadS a
Numeric.readFloat String
dec)
     Int
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero
  LispVal -> Parser LispVal
parseNumberExponent LispVal
f

-- | Parse the exponent section of a floating point number
--   in scientific notation. Eg "e10" from "1.0e10"
parseNumberExponent :: LispVal -> Parser LispVal
parseNumberExponent :: LispVal -> Parser LispVal
parseNumberExponent LispVal
n = do 
  String
expnt <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
 -> ParsecT String () Identity String)
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"Ee"
  case (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
expnt) of
    Int
0 -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
n
    Int
1 -> do
      LispVal
num <- Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser LispVal
parseDecimalNumber
      case LispVal
num of
        Number Integer
nexp -> LispVal -> Integer -> Parser LispVal
forall a tok st.
Integral a =>
LispVal -> a -> ParsecT [tok] st Identity LispVal
buildResult LispVal
n Integer
nexp
        LispVal
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero
    Int
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero
 where 
  buildResult :: LispVal -> a -> ParsecT [tok] st Identity LispVal
buildResult (Number Integer
num) a
nexp = LispVal -> ParsecT [tok] st Identity LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ParsecT [tok] st Identity LispVal)
-> LispVal -> ParsecT [tok] st Identity LispVal
forall a b. (a -> b) -> a -> b
$ Double -> LispVal
Float (Double -> LispVal) -> Double -> LispVal
forall a b. (a -> b) -> a -> b
$ (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
num) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
10 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nexp))
  buildResult (Float Double
num) a
nexp = LispVal -> ParsecT [tok] st Identity LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> ParsecT [tok] st Identity LispVal)
-> LispVal -> ParsecT [tok] st Identity LispVal
forall a b. (a -> b) -> a -> b
$ Double -> LispVal
Float (Double -> LispVal) -> Double -> LispVal
forall a b. (a -> b) -> a -> b
$ Double
num Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
10 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nexp))
  buildResult LispVal
_ a
_ = ParsecT [tok] st Identity LispVal
forall tok st a. GenParser tok st a
pzero

-- |Parse a rational number
parseRationalNumber :: Parser LispVal
parseRationalNumber :: Parser LispVal
parseRationalNumber = do
  LispVal
pnumerator <- Parser LispVal
parseDecimalNumber
  case LispVal
pnumerator of
    Number Integer
n -> do
      Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/'
      String
sign <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-")
      String
num <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
      if (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sign) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
         then Parser LispVal
forall tok st a. GenParser tok st a
pzero
         else do
             let pdenominator :: Integer
pdenominator = String -> Integer
forall a. Read a => String -> a
read (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ String
sign String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
num
             if Integer
pdenominator Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
                then LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number Integer
0 -- TODO: Prevents a div-by-zero error, but not really correct either
                else LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Rational -> LispVal
Rational (Rational -> LispVal) -> Rational -> LispVal
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
pdenominator
    LispVal
_ -> Parser LispVal
forall tok st a. GenParser tok st a
pzero

-- |Parse a complex number
parseComplexNumber :: Parser LispVal
parseComplexNumber :: Parser LispVal
parseComplexNumber = do
  LispVal
lispreal <- (Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser LispVal
parseRealNumber Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser LispVal
parseRationalNumber Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal
parseDecimalNumber)
  let real :: Double
real = case LispVal
lispreal of
                  Number Integer
n -> Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
n
                  Rational Rational
r -> Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r
                  Float Double
f -> Double
f
                  LispVal
_ -> Double
0
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+'
  LispVal
lispimag <- (Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser LispVal
parseRealNumber Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser LispVal
parseRationalNumber Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal
parseDecimalNumber)
  let imag :: Double
imag = case LispVal
lispimag of
                  Number Integer
n -> Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
n
                  Rational Rational
r -> Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r
                  Float Double
f -> Double
f
                  LispVal
_ -> Double
0 -- Case should never be reached
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'i'
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Complex Double -> LispVal
Complex (Complex Double -> LispVal) -> Complex Double -> LispVal
forall a b. (a -> b) -> a -> b
$ Double
real Double -> Double -> Complex Double
forall a. a -> a -> Complex a
:+ Double
imag

-- |Parse an escaped character
parseEscapedChar :: forall st .
                    GenParser Char st Char
parseEscapedChar :: GenParser Char st Char
parseEscapedChar = do
  Char
_ <- Char -> GenParser Char st Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
  Char
c <- GenParser Char st Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
  case Char
c of
    Char
'a' -> Char -> GenParser Char st Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\a'
    Char
'b' -> Char -> GenParser Char st Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\b'
    Char
'n' -> Char -> GenParser Char st Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
    Char
't' -> Char -> GenParser Char st Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\t'
    Char
'r' -> Char -> GenParser Char st Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\r'
    Char
'x' -> do
        String
num <- GenParser Char st Char -> ParsecT String st Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (GenParser Char st Char -> ParsecT String st Identity String)
-> GenParser Char st Char -> ParsecT String st Identity String
forall a b. (a -> b) -> a -> b
$ GenParser Char st Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter GenParser Char st Char
-> GenParser Char st Char -> GenParser Char st Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenParser Char st Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
        Char
_ <- Char -> GenParser Char st Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';'
        String -> GenParser Char st Char
forall st. String -> GenParser Char st Char
parseHexScalar String
num
    Char
_ -> Char -> GenParser Char st Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c

-- |Parse a hexidecimal scalar
parseHexScalar :: String -> GenParser Char st Char
parseHexScalar :: String -> GenParser Char st Char
parseHexScalar String
num = do
    let ns :: [(Int, String)]
ns = ReadS Int
forall a. (Eq a, Num a) => ReadS a
Numeric.readHex String
num
    case [(Int, String)]
ns of
        [] -> String -> GenParser Char st Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GenParser Char st Char)
-> String -> GenParser Char st Char
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse hex value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
num
        [(Int, String)]
_ -> Char -> GenParser Char st Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> GenParser Char st Char) -> Char -> GenParser Char st Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
DC.chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int, String) -> Int
forall a b. (a, b) -> a
fst ((Int, String) -> Int) -> (Int, String) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, String)] -> (Int, String)
forall a. [a] -> a
head [(Int, String)]
ns

-- |Parse a string
parseString :: Parser LispVal
parseString :: Parser LispVal
parseString = do
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
  String
x <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
forall st. GenParser Char st Char
parseEscapedChar ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"")
  Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
String String
x

-- |Parse a vector
parseVector :: Parser LispVal
parseVector :: Parser LispVal
parseVector = do
  [LispVal]
vals <- Parser LispVal
-> ParsecT String () Identity ()
-> ParsecT String () Identity [LispVal]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy Parser LispVal
parseExpr ParsecT String () Identity ()
whiteSpace
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector ((Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, ([LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
vals Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [LispVal]
vals)

-- |Parse a bytevector
parseByteVector :: Parser LispVal
parseByteVector :: Parser LispVal
parseByteVector = do
  [LispVal]
ns <- Parser LispVal
-> ParsecT String () Identity ()
-> ParsecT String () Identity [LispVal]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy Parser LispVal
parseNumber ParsecT String () Identity ()
whiteSpace
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (LispVal -> Word8) -> [LispVal] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> Word8
conv [LispVal]
ns
 where 
   conv :: LispVal -> Word8
conv (Number Integer
n) = Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
n :: Word8
   conv LispVal
_ = Word8
0 :: Word8

-- |Parse a hash table. The table is either empty or is made up of
--  an alist (associative list)
parseHashTable :: Parser LispVal
parseHashTable :: Parser LispVal
parseHashTable = do
  -- This function uses explicit recursion to loop over the parsed list:
  -- As long as it is an alist, the members are appended to an accumulator
  -- so they can be added to the hash table. However, if the input list is
  -- determined not to be an alist, Nothing is returned, letting the parser
  -- know that a valid hashtable was not read.
  let f :: [(LispVal, LispVal)] -> [LispVal] -> Maybe [(LispVal, LispVal)]
      f :: [(LispVal, LispVal)] -> [LispVal] -> Maybe [(LispVal, LispVal)]
f [(LispVal, LispVal)]
acc [] = [(LispVal, LispVal)] -> Maybe [(LispVal, LispVal)]
forall a. a -> Maybe a
Just [(LispVal, LispVal)]
acc
      f [(LispVal, LispVal)]
acc (List [LispVal
a, LispVal
b] :[LispVal]
ls) = [(LispVal, LispVal)] -> [LispVal] -> Maybe [(LispVal, LispVal)]
f ([(LispVal, LispVal)]
acc [(LispVal, LispVal)]
-> [(LispVal, LispVal)] -> [(LispVal, LispVal)]
forall a. [a] -> [a] -> [a]
++ [(LispVal
a, LispVal
b)]) [LispVal]
ls
      f [(LispVal, LispVal)]
acc (DottedList [LispVal
a] LispVal
b :[LispVal]
ls) = [(LispVal, LispVal)] -> [LispVal] -> Maybe [(LispVal, LispVal)]
f ([(LispVal, LispVal)]
acc [(LispVal, LispVal)]
-> [(LispVal, LispVal)] -> [(LispVal, LispVal)]
forall a. [a] -> [a] -> [a]
++ [(LispVal
a, LispVal
b)]) [LispVal]
ls
      f [(LispVal, LispVal)]
_ (LispVal
_:[LispVal]
_) = Maybe [(LispVal, LispVal)]
forall a. Maybe a
Nothing
  [LispVal]
vals <- Parser LispVal
-> ParsecT String () Identity ()
-> ParsecT String () Identity [LispVal]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy Parser LispVal
parseExpr ParsecT String () Identity ()
whiteSpace
  let mvals :: Maybe [(LispVal, LispVal)]
mvals = [(LispVal, LispVal)] -> [LispVal] -> Maybe [(LispVal, LispVal)]
f [] [LispVal]
vals
  case Maybe [(LispVal, LispVal)]
mvals of
    Just [(LispVal, LispVal)]
m -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> LispVal
HashTable (Map LispVal LispVal -> LispVal) -> Map LispVal LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ [(LispVal, LispVal)] -> Map LispVal LispVal
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList [(LispVal, LispVal)]
m
    Maybe [(LispVal, LispVal)]
Nothing -> Parser LispVal
forall tok st a. GenParser tok st a
pzero

-- |Parse a list
parseList :: Parser LispVal
parseList :: Parser LispVal
parseList = ([LispVal] -> LispVal)
-> ParsecT String () Identity [LispVal] -> Parser LispVal
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [LispVal] -> LispVal
List (ParsecT String () Identity [LispVal] -> Parser LispVal)
-> ParsecT String () Identity [LispVal] -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ Parser LispVal
-> ParsecT String () Identity ()
-> ParsecT String () Identity [LispVal]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy Parser LispVal
parseExpr ParsecT String () Identity ()
whiteSpace
-- TODO: wanted to use endBy (or a variant) above, but it causes an error such that dotted lists are not parsed

-- |Parse a dotted list (scheme pair)
parseDottedList :: Parser LispVal
parseDottedList :: Parser LispVal
parseDottedList = do
  [LispVal]
phead <- Parser LispVal
-> ParsecT String () Identity ()
-> ParsecT String () Identity [LispVal]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
endBy Parser LispVal
parseExpr ParsecT String () Identity ()
whiteSpace
  case [LispVal]
phead of
    [] -> Parser LispVal
forall tok st a. GenParser tok st a
pzero -- car is required; no match   
    [LispVal]
_ -> do
      LispVal
ptail <- ParsecT String () Identity String
dot ParsecT String () Identity String
-> Parser LispVal -> Parser LispVal
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser LispVal
parseExpr
      case LispVal
ptail of
        DottedList [LispVal]
ls LispVal
l -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList ([LispVal]
phead [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
ls) LispVal
l 
        -- Issue #41
        -- Improper lists are tricky because if an improper list ends in a 
        -- proper list, then it becomes proper as well. The following cases 
        -- handle that, as well as preserving necessary functionality when 
        -- appropriate, such as for unquoting.
        --
        -- FUTURE: I am not sure if this is complete, in fact the "unquote" 
        -- seems like it could either be incorrect or one special case among 
        -- others. Anyway, for the 3.3 release this is good enough to pass all
        -- test cases. It will be revisited later if necessary.
        --
        List (Atom String
"unquote" : [LispVal]
_) -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList [LispVal]
phead LispVal
ptail 
        List [LispVal]
ls -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
phead [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
ls
        {- Regarding above, see 
           http://community.schemewiki.org/?scheme-faq-language#dottedapp
         
           Note, however, that most Schemes expand literal lists occurring in 
           function applications, e.g. (foo bar . (1 2 3)) is expanded into 
           (foo bar 1 2 3) by the reader. It is not entirely clear whether this 
           is a consequence of the standard - the notation is not part of the 
           R5RS grammar but there is strong evidence to suggest a Scheme 
           implementation cannot comply with all of R5RS without performing this
           transformation. -}
        LispVal
_ -> LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList [LispVal]
phead LispVal
ptail

-- |Parse a quoted expression
parseQuoted :: Parser LispVal
parseQuoted :: Parser LispVal
parseQuoted = do
  Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\''
  LispVal
x <- Parser LispVal
parseExpr
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
x]

-- |Parse a quasi-quoted expression
parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
  Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'`'
  LispVal
x <- Parser LispVal
parseExpr
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quasiquote", LispVal
x]

-- |Parse an unquoted expression (a quasiquotated expression preceded
--  by a comma)
parseUnquoted :: Parser LispVal
parseUnquoted :: Parser LispVal
parseUnquoted = do
  Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
  LispVal
x <- Parser LispVal
parseExpr
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"unquote", LispVal
x]

-- |Parse an unquote-spliced expression
parseUnquoteSpliced :: Parser LispVal
parseUnquoteSpliced :: Parser LispVal
parseUnquoteSpliced = do
  String
_ <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity String
-> ParsecT String () Identity String
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
",@")
  LispVal
x <- Parser LispVal
parseExpr
  LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> Parser LispVal) -> LispVal -> Parser LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"unquote-splicing", LispVal
x]

-- FUTURE: should be able to use the grammar from R5RS
-- to make parsing more efficient (mostly by minimizing
-- or eliminating the number of try's below)

-- |Parse an expression
parseExpr :: Parser LispVal
parseExpr :: Parser LispVal
parseExpr =
      Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme Parser LispVal
parseComplexNumber)
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme Parser LispVal
parseRationalNumber)
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme Parser LispVal
parseRealNumber)
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme Parser LispVal
parseNumber)
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme Parser LispVal
parseChar
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal
parseUnquoteSpliced
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do String
_ <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity String
-> ParsecT String () Identity String
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#(")
         LispVal
x <- Parser LispVal
parseVector
         Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
         LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
x
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do String
_ <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity String
-> ParsecT String () Identity String
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#u8(")
         LispVal
x <- Parser LispVal
parseByteVector
         Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
         LispVal -> Parser LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
x
--  <|> do _ <- try (lexeme $ string "#hash(")
--         x <- parseHashTable
--         _ <- lexeme $ char ')'
--         return x
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try Parser LispVal
parseAtom
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme Parser LispVal
parseString
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
lexeme Parser LispVal
parseBool
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal
parseQuoted
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal
parseQuasiQuoted
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal
parseUnquoted
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
parens Parser LispVal
parseList)
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
parens Parser LispVal
parseDottedList
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
brackets Parser LispVal
parseList)
  Parser LispVal -> Parser LispVal -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser LispVal -> Parser LispVal
forall a.
ParsecT String () Identity a -> ParsecT String () Identity a
brackets Parser LispVal
parseDottedList
  Parser LispVal -> String -> Parser LispVal
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"Expression"

-- |Initial parser used by the high-level parse functions
mainParser :: Parser LispVal
mainParser :: Parser LispVal
mainParser = do
    ()
_ <- ParsecT String () Identity ()
whiteSpace
    Parser LispVal
parseExpr

-- |Use a parser to parse the given text, throwing an error
--  if there is a problem parsing the text.
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow Parser a
parser String
input = case Parser a -> String -> String -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser a
parser String
"lisp" String
input of
  Left ParseError
err -> LispError -> ThrowsError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ThrowsError a) -> LispError -> ThrowsError a
forall a b. (a -> b) -> a -> b
$ ParseError -> LispError
Parser ParseError
err
  Right a
val -> a -> ThrowsError a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- |Parse an expression from a string of text
readExpr :: String -> ThrowsError LispVal
readExpr :: String -> ThrowsError LispVal
readExpr = Parser LispVal -> String -> ThrowsError LispVal
forall a. Parser a -> String -> ThrowsError a
readOrThrow Parser LispVal
mainParser

-- |Parse many expressions from a string of text
readExprList :: String -> ThrowsError [LispVal]
readExprList :: String -> ThrowsError [LispVal]
readExprList = ParsecT String () Identity [LispVal]
-> String -> ThrowsError [LispVal]
forall a. Parser a -> String -> ThrowsError a
readOrThrow (Parser LispVal
-> ParsecT String () Identity ()
-> ParsecT String () Identity [LispVal]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
endBy Parser LispVal
mainParser ParsecT String () Identity ()
whiteSpace)