husk-scheme-3.20: hs-src/Language/Scheme/Parser.hs
{-# 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
= emptyDef
{ P.commentStart = "#|"
, P.commentEnd = "|#"
, P.commentLine = ";"
, P.nestedComments = True
, P.identStart = letter <|> symbol
, P.identLetter = letter <|> digit <|> symbol
, P.reservedNames = []
, P.caseSensitive = True
}
#if __GLASGOW_HASKELL__ >= 702
lexer :: P.GenTokenParser String () Data.Functor.Identity.Identity
#endif
lexer = P.makeTokenParser lispDef
#if __GLASGOW_HASKELL__ >= 702
dot :: ParsecT String () Identity String
#endif
dot = P.dot lexer
#if __GLASGOW_HASKELL__ >= 702
parens :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
parens = P.parens lexer
#if __GLASGOW_HASKELL__ >= 702
brackets :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
brackets = P.brackets lexer
#if __GLASGOW_HASKELL__ >= 702
identifier :: ParsecT String () Identity String
#endif
identifier = P.identifier lexer
#if __GLASGOW_HASKELL__ >= 702
whiteSpace :: ParsecT String () Identity ()
#endif
whiteSpace = P.whiteSpace lexer
#if __GLASGOW_HASKELL__ >= 702
lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
lexeme = P.lexeme lexer
-- |Match a special character
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~."
-- |Parse an atom (scheme symbol)
parseAtom :: Parser LispVal
parseAtom = do
atom <- identifier
if atom == "."
then pzero -- Do not match this form
else return $ Atom atom
-- |Parse a boolean
parseBool :: Parser LispVal
parseBool = do _ <- string "#"
x <- oneOf "tf"
return $ case x of
't' -> Bool True
'f' -> Bool False
_ -> Bool False
-- |Parse a character
parseChar :: Parser LispVal
parseChar = do
_ <- try (string "#\\")
c <- anyChar
r <- many (letter <|> digit)
let pchr = c : r
case pchr of
"space" -> return $ Char ' '
"newline" -> return $ Char '\n'
"alarm" -> return $ Char '\a'
"backspace" -> return $ Char '\b'
"delete" -> return $ Char '\DEL'
"escape" -> return $ Char '\ESC'
"null" -> return $ Char '\0'
"return" -> return $ Char '\n'
"tab" -> return $ Char '\t'
_ -> case (c : r) of
[ch] -> return $ Char ch
('x' : hexs) -> do
rv <- parseHexScalar hexs
return $ Char rv
_ -> pzero
-- |Parse an integer in octal notation, base 8
parseOctalNumber :: Parser LispVal
parseOctalNumber = do
_ <- try (string "#o")
sign <- many (oneOf "-")
num <- many1 (oneOf "01234567")
case (length sign) of
0 -> return $ Number $ fst $ head (Numeric.readOct num)
1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ head (Numeric.readOct num)
_ -> pzero
-- |Parse an integer in binary notation, base 2
parseBinaryNumber :: Parser LispVal
parseBinaryNumber = do
_ <- try (string "#b")
sign <- many (oneOf "-")
num <- many1 (oneOf "01")
case (length sign) of
0 -> return $ Number $ fst $ head (Numeric.readInt 2 (`elem` "01") DC.digitToInt num)
1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ head (Numeric.readInt 2 (`elem` "01") DC.digitToInt num)
_ -> pzero
-- |Parse an integer in hexadecimal notation, base 16
parseHexNumber :: Parser LispVal
parseHexNumber = do
_ <- try (string "#x")
sign <- many (oneOf "-")
num <- many1 (digit <|> oneOf "abcdefABCDEF")
case (length sign) of
0 -> return $ Number $ fst $ head (Numeric.readHex num)
1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ head (Numeric.readHex num)
_ -> pzero
-- |Parser for Integer, base 10
parseDecimalNumber :: Parser LispVal
parseDecimalNumber = do
_ <- try (many (string "#d"))
sign <- many (oneOf "-")
num <- many1 digit
if (length sign) > 1
then pzero
else return $ (Number . read) $ sign ++ 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 = do
num <- parseDecimalNumber
parseNumberExponent num
-- |Parse an integer in any base
parseNumber :: Parser LispVal
parseNumber = parseDecimalNumberMaybeExponent <|>
parseHexNumber <|>
parseBinaryNumber <|>
parseOctalNumber <?>
"Unable to parse number"
-- |Parse a floating point number
parseRealNumber :: Parser LispVal
parseRealNumber = do
sign <- many (oneOf "-+")
num <- many digit
_ <- char '.'
frac <- many1 digit
let dec = if not (null num)
then num ++ "." ++ frac
else "0." ++ frac
f <- case (length sign) of
0 -> return $ Float $ fst $ head (Numeric.readFloat dec)
-- Bit of a hack, but need to support the + sign as well as the minus.
1 -> if sign == "-"
then return $ Float $ (*) (-1.0) $ fst $ head (Numeric.readFloat dec)
else return $ Float $ fst $ head (Numeric.readFloat dec)
_ -> pzero
parseNumberExponent f
-- | Parse the exponent section of a floating point number
-- in scientific notation. Eg "e10" from "1.0e10"
parseNumberExponent :: LispVal -> Parser LispVal
parseNumberExponent n = do
expnt <- many $ oneOf "Ee"
case (length expnt) of
0 -> return n
1 -> do
num <- try parseDecimalNumber
case num of
Number nexp -> buildResult n nexp
_ -> pzero
_ -> pzero
where
buildResult (Number num) nexp = return $ Float $ (fromIntegral num) * (10 ** (fromIntegral nexp))
buildResult (Float num) nexp = return $ Float $ num * (10 ** (fromIntegral nexp))
buildResult _ _ = pzero
-- |Parse a rational number
parseRationalNumber :: Parser LispVal
parseRationalNumber = do
pnumerator <- parseDecimalNumber
case pnumerator of
Number n -> do
_ <- char '/'
sign <- many (oneOf "-")
num <- many1 digit
if (length sign) > 1
then pzero
else do
let pdenominator = read $ sign ++ num
if pdenominator == 0
then return $ Number 0 -- TODO: Prevents a div-by-zero error, but not really correct either
else return $ Rational $ n % pdenominator
_ -> pzero
-- |Parse a complex number
parseComplexNumber :: Parser LispVal
parseComplexNumber = do
lispreal <- (try parseRealNumber <|> try parseRationalNumber <|> parseDecimalNumber)
let real = case lispreal of
Number n -> fromInteger n
Rational r -> fromRational r
Float f -> f
_ -> 0
_ <- char '+'
lispimag <- (try parseRealNumber <|> try parseRationalNumber <|> parseDecimalNumber)
let imag = case lispimag of
Number n -> fromInteger n
Rational r -> fromRational r
Float f -> f
_ -> 0 -- Case should never be reached
_ <- char 'i'
return $ Complex $ real :+ imag
-- |Parse an escaped character
parseEscapedChar :: forall st .
GenParser Char st Char
parseEscapedChar = do
_ <- char '\\'
c <- anyChar
case c of
'a' -> return '\a'
'b' -> return '\b'
'n' -> return '\n'
't' -> return '\t'
'r' -> return '\r'
'x' -> do
num <- many $ letter <|> digit
_ <- char ';'
parseHexScalar num
_ -> return c
-- |Parse a hexidecimal scalar
parseHexScalar :: String -> GenParser Char st Char
parseHexScalar num = do
let ns = Numeric.readHex num
case ns of
[] -> fail $ "Unable to parse hex value " ++ show num
_ -> return $ DC.chr $ fst $ head ns
-- |Parse a string
parseString :: Parser LispVal
parseString = do
_ <- char '"'
x <- many (parseEscapedChar <|> noneOf "\"")
_ <- char '"'
return $ String x
-- |Parse a vector
parseVector :: Parser LispVal
parseVector = do
vals <- sepBy parseExpr whiteSpace
return $ Vector (listArray (0, (length vals - 1)) vals)
-- |Parse a bytevector
parseByteVector :: Parser LispVal
parseByteVector = do
ns <- sepBy parseNumber whiteSpace
return $ ByteVector $ BS.pack $ map conv ns
where
conv (Number n) = fromInteger n :: Word8
conv _ = 0 :: Word8
-- |Parse a hash table. The table is either empty or is made up of
-- an alist (associative list)
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 acc [] = Just acc
f acc (List [a, b] :ls) = f (acc ++ [(a, b)]) ls
f acc (DottedList [a] b :ls) = f (acc ++ [(a, b)]) ls
f _ (_:_) = Nothing
vals <- sepBy parseExpr whiteSpace
let mvals = f [] vals
case mvals of
Just m -> return $ HashTable $ Data.Map.fromList m
Nothing -> pzero
-- |Parse a list
parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr 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 = do
phead <- endBy parseExpr whiteSpace
case phead of
[] -> pzero -- car is required; no match
_ -> do
ptail <- dot >> parseExpr
case ptail of
DottedList ls l -> return $ DottedList (phead ++ ls) 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 "unquote" : _) -> return $ DottedList phead ptail
List ls -> return $ List $ phead ++ 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. -}
_ -> return $ DottedList phead ptail
-- |Parse a quoted expression
parseQuoted :: Parser LispVal
parseQuoted = do
_ <- lexeme $ char '\''
x <- parseExpr
return $ List [Atom "quote", x]
-- |Parse a quasi-quoted expression
parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
_ <- lexeme $ char '`'
x <- parseExpr
return $ List [Atom "quasiquote", x]
-- |Parse an unquoted expression (a quasiquotated expression preceded
-- by a comma)
parseUnquoted :: Parser LispVal
parseUnquoted = do
_ <- try (lexeme $ char ',')
x <- parseExpr
return $ List [Atom "unquote", x]
-- |Parse an unquote-spliced expression
parseUnquoteSpliced :: Parser LispVal
parseUnquoteSpliced = do
_ <- try (lexeme $ string ",@")
x <- parseExpr
return $ List [Atom "unquote-splicing", 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 =
try (lexeme parseComplexNumber)
<|> try (lexeme parseRationalNumber)
<|> try (lexeme parseRealNumber)
<|> try (lexeme parseNumber)
<|> lexeme parseChar
<|> parseUnquoteSpliced
<|> do _ <- try (lexeme $ string "#(")
x <- parseVector
_ <- lexeme $ char ')'
return x
<|> do _ <- try (lexeme $ string "#u8(")
x <- parseByteVector
_ <- lexeme $ char ')'
return x
-- <|> do _ <- try (lexeme $ string "#hash(")
-- x <- parseHashTable
-- _ <- lexeme $ char ')'
-- return x
<|> try parseAtom
<|> lexeme parseString
<|> lexeme parseBool
<|> parseQuoted
<|> parseQuasiQuoted
<|> parseUnquoted
<|> try (parens parseList)
<|> parens parseDottedList
<|> try (brackets parseList)
<|> brackets parseDottedList
<?> "Expression"
-- |Initial parser used by the high-level parse functions
mainParser :: Parser LispVal
mainParser = do
_ <- whiteSpace
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 input = case parse parser "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
-- |Parse an expression from a string of text
readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow mainParser
-- |Parse many expressions from a string of text
readExprList :: String -> ThrowsError [LispVal]
readExprList = readOrThrow (endBy mainParser whiteSpace)