added progress to curr master state, however different results, and some programs not terminating

parent b097051d
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Control.Arrow.Transformer.Abstract.FiniteEnvStore where
import Prelude hiding ((.),read,Maybe(..),lookup,map)
import qualified Prelude as P
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.Transformer.State
import Control.Arrow.State as State
import Control.Arrow.Store
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Fix.Context
import Control.Arrow.Environment as Env
import Control.Arrow.Closure
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Utils
import Data.Abstract.Widening (Widening)
import Data.Abstract.Closure (Closure)
import qualified Data.Abstract.Closure as Cls
import Data.HashSet(HashSet)
import qualified Data.HashSet as Set
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as Map
import Data.Order
import Data.Identifiable
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
type Alloc var addr val c = EnvStoreT var addr val c (var,val) addr
newtype EnvStoreT var addr val c x y = EnvStoreT (ConstT (Alloc var addr val c, Widening val) (ReaderT (HashMap var addr) (StateT (HashMap addr val) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans, ArrowLowerBounded,
ArrowFail e, ArrowExcept e, ArrowRun, ArrowCont,
ArrowContext ctx)
instance (Identifiable var, Identifiable addr, Complete val, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvStoreT var addr val c) where
type Join y (EnvStoreT var addr val c) = ()
lookup (EnvStoreT f) (EnvStoreT g) = EnvStoreT $ proc (var,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case do { addr <- Map.lookup var env; Map.lookup addr store } of
P.Just val -> f -< (val,x)
P.Nothing -> g -< x
extend (EnvStoreT f) = EnvStoreT $ askConst $ \(EnvStoreT alloc,widening) -> proc (var,val,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
addr <- alloc -< (var,val)
State.put -< Map.insertWith (\old new -> snd (widening old new)) addr val store
Reader.local f -< (Map.insert var addr env, x)
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (Identifiable var, Identifiable addr, ArrowChoice c, Profunctor c) => ArrowStore var val (EnvStoreT var addr val c) where
type Join y (EnvStoreT var addr val c) = ()
read (EnvStoreT f) (EnvStoreT g) = EnvStoreT $ proc (var,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case do { addr <- Map.lookup var env; Map.lookup addr store } of
P.Just val -> f -< (val,x)
P.Nothing -> g -< x
write = EnvStoreT $ askConst $ \(EnvStoreT _,widening) -> proc (var, val) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case Map.lookup var env of
P.Just addr -> State.put -< Map.insertWith (\old new -> snd (widening old new)) addr val store
P.Nothing -> returnA -< ()
returnA -< ()
{-# INLINE read #-}
{-# INLINE write #-}
instance (Identifiable var, Identifiable addr, Identifiable expr, ArrowEffectCommutative c, ArrowChoice c, Profunctor c) =>
ArrowClosure expr (Closure expr (HashSet (HashMap var addr))) (EnvStoreT var addr val c) where
type Join y (Closure expr (HashSet (HashMap var addr))) (EnvStoreT var addr val c) = Complete y
closure = EnvStoreT $ proc expr -> do
env <- Reader.ask -< ()
returnA -< Cls.closure expr (Set.singleton env)
apply (EnvStoreT f) = Cls.apply $ proc ((expr,envs),x) ->
(| joinList (error "encountered an empty set of environments" -< ())
(\env -> EnvStoreT (Reader.local f) -< (env,(expr,x))) |) (Set.toList envs)
{-# INLINE closure #-}
{-# INLINE apply #-}
instance (Identifiable var, Identifiable addr, Complete val, IsClosure val (HashSet (HashMap var addr)), ArrowEffectCommutative c, ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvStoreT var addr val c) where
letRec (EnvStoreT f) = EnvStoreT $ askConst $ \(EnvStoreT alloc,widening) -> proc (bindings,x) -> do
env <- Reader.ask -< ()
addrs <- map alloc -< bindings
let env' = Map.fromList [ (var,addr) | ((var,_), addr) <- zip bindings addrs ] `Map.union` env
vals = Map.fromList [ (addr, setEnvironment (Set.singleton env') val) | (addr, (_,val)) <- zip addrs bindings ]
State.modify' (\(vals,store) -> ((), Map.unionWith (\old new -> snd (widening old new)) store vals)) -< vals
Reader.local f -< (env',x)
{-# INLINE letRec #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvStoreT var addr val c) where
app = EnvStoreT (app .# first coerce)
{-# INLINE app #-}
instance ArrowLift (EnvStoreT var addr val) where
lift' = EnvStoreT . lift' . lift' . lift'
{-# INLINE lift' #-}
instance (Complete y, ArrowEffectCommutative c, Arrow c, Profunctor c) => ArrowComplete y (EnvStoreT var addr val c) where
EnvStoreT f <> EnvStoreT g = EnvStoreT (rmap (uncurry ()) (f &&& g))
type instance Fix (EnvStoreT var addr val c) x y = EnvStoreT var addr val (Fix c (HashMap addr val,(HashMap var addr,x)) (HashMap addr val,y))
deriving instance (Profunctor c, Arrow c, ArrowFix (c (HashMap addr val,(HashMap var addr,x)) (HashMap addr val,y))) => ArrowFix (EnvStoreT var addr val c x y)
......@@ -32,7 +32,7 @@ import Data.Coerce
newtype FailureT e c x y = FailureT (KleisliT (Error e) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r,ArrowState s,ArrowReader r,ArrowExcept exc,
ArrowEnv var val, ArrowClosure expr cls,ArrowStore var val)
ArrowEnv var val, ArrowLetRec var val, ArrowClosure expr cls,ArrowStore var val)
runFailureT :: FailureT e c x y -> c x (Error e y)
runFailureT = coerce
......
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Control.Arrow.Transformer.Concrete.FiniteEnvStore where
import Prelude hiding ((.),read,Maybe(..),lookup,map)
import qualified Prelude as P
import Control.Category
import Control.Arrow
import Control.Arrow.Cont
import Control.Arrow.Const
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Reader as Reader
import Control.Arrow.Transformer.State
import Control.Arrow.State as State
import Control.Arrow.Store
import Control.Arrow.Fail
import Control.Arrow.Except
import Control.Arrow.Trans
import Control.Arrow.Fix.Context
import Control.Arrow.Environment as Env
import Control.Arrow.Closure
import Control.Arrow.Fix
import Control.Arrow.Order
import Control.Arrow.Utils
-- import Data.Abstract.Widening (Widening)
-- import Data.Abstract.Closure (Closure)
-- import qualified Data.Abstract.Closure as Cls
import Data.Concrete.Closure (Closure)
import qualified Data.Concrete.Closure as Cls
import Data.HashSet()
-- import qualified Data.HashSet as Set
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as Map
import Data.Order()
import Data.Identifiable
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
type Alloc var addr val c = EnvStoreT var addr val c (var,val) addr
newtype EnvStoreT var addr val c x y = EnvStoreT (ConstT (Alloc var addr val c) (ReaderT (HashMap var addr) (StateT (HashMap addr val) c)) x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans, ArrowLowerBounded,
ArrowFail e, ArrowExcept e, ArrowRun, ArrowCont,
ArrowContext ctx, ArrowState (HashMap addr val))
-- read (StoreT f) (StoreT g) = StoreT $ proc (var,x) -> do
-- s <- get -< ()
-- case S.lookup var s of
-- Just v -> f -< (v,x)
-- Nothing -> g -< x
instance (Identifiable var, Identifiable addr, ArrowChoice c, Profunctor c) => ArrowEnv var val (EnvStoreT var addr val c) where
type Join y (EnvStoreT var addr val c) = ()
lookup (EnvStoreT f) (EnvStoreT g) = EnvStoreT $ proc (var,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case do { addr <- Map.lookup var env; Map.lookup addr store } of
P.Just val -> f -< (val,x)
P.Nothing -> g -< x
extend (EnvStoreT f) = EnvStoreT $ askConst $ \(EnvStoreT alloc) -> proc (var,val,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
addr <- alloc -< (var, val)
State.put -< Map.insert addr val store
Reader.local f -< (Map.insert var addr env, x)
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance (Identifiable var, Identifiable addr, ArrowChoice c, Profunctor c) => ArrowStore var val (EnvStoreT var addr val c) where
type Join y (EnvStoreT var addr val c) = ()
read (EnvStoreT f) (EnvStoreT g) = EnvStoreT $ proc (var,x) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case do { addr <- Map.lookup var env; Map.lookup addr store } of
P.Just val -> f -< (val,x)
P.Nothing -> g -< x
write = EnvStoreT $ proc (var, val) -> do
env <- Reader.ask -< ()
store <- State.get -< ()
case Map.lookup var env of
P.Just addr -> State.put -< Map.insert addr val store
P.Nothing -> returnA -< ()
returnA -< ()
{-# INLINE read #-}
{-# INLINE write #-}
instance (Identifiable var, Identifiable addr, Identifiable expr, ArrowChoice c, Profunctor c) =>
ArrowClosure expr (Closure expr (HashMap var addr)) (EnvStoreT var addr val c) where
type Join y (Closure expr (HashMap var addr)) (EnvStoreT var addr val c) = ()
closure = EnvStoreT $ proc expr -> do
env <- Reader.ask -< ()
returnA -< Cls.Closure expr env
apply (EnvStoreT f) = EnvStoreT $ proc (Cls.Closure expr env,x) ->
Reader.local f -< (env,(expr,x))
{-# INLINE closure #-}
{-# INLINE apply #-}
instance (Identifiable var, Identifiable addr, IsClosure val (HashMap var addr), ArrowChoice c, Profunctor c) => ArrowLetRec var val (EnvStoreT var addr val c) where
letRec (EnvStoreT f) = EnvStoreT $ askConst $ \(EnvStoreT alloc) -> proc (bindings,x) -> do
env <- Reader.ask -< ()
addrs <- map alloc -< bindings
let env' = Map.fromList [ (var,addr) | ((var,_), addr) <- zip bindings addrs ] `Map.union` env
vals = Map.fromList [ (addr, setEnvironment env' val) | (addr, (_,val)) <- zip addrs bindings ]
-- changed Map.union store vals to Map.union vals store, because for equal keys left store is prioritized
-- Probably not sound because data can be lost from store
-- State.modify' (\(vals,store) -> ((), Map.union vals store)) -< vals
State.modify' (\(vals,store) -> ((), Map.union store vals)) -< vals
Reader.local f -< (env',x)
{-# INLINE letRec #-}
instance (ArrowApply c, Profunctor c) => ArrowApply (EnvStoreT var addr val c) where
app = EnvStoreT (app .# first coerce)
{-# INLINE app #-}
instance ArrowLift (EnvStoreT var addr val) where
lift' = EnvStoreT . lift' . lift' . lift'
{-# INLINE lift' #-}
instance ArrowState s c => ArrowState s (EnvStoreT var addr val c) where
get = lift' State.get
put = lift' State.put
-- instance (Complete y, ArrowEffectCommutative c, Arrow c, Profunctor c) => ArrowComplete y (EnvStoreT var addr val c) where
-- EnvStoreT f <⊔> EnvStoreT g = EnvStoreT (rmap (uncurry (⊔)) (f &&& g))
type instance Fix (EnvStoreT var addr val c) x y = EnvStoreT var addr val (Fix c (HashMap addr val,(HashMap var addr,x)) (HashMap addr val,y))
deriving instance (Profunctor c, Arrow c, ArrowFix (c (HashMap addr val,(HashMap var addr,x)) (HashMap addr val,y))) => ArrowFix (EnvStoreT var addr val c x y)
......@@ -39,7 +39,13 @@ data Val = NumVal Int | ClosureVal Cls deriving (Eq,Generic)
-- implemented by instantiating the shared semantics with the concrete
-- interpreter arrow `Interp`.
evalConcrete :: [(Text,Val)] -> State Label Expr -> Error String Val
evalConcrete env e = run (eval :: ValueT Val (EnvT Env (FailureT String (->))) Expr Val) (M.fromList env,generate e)
evalConcrete env e = run
(eval ::
ValueT Val
(EnvT Env
(FailureT String
(->))) Expr Val)
(M.fromList env,generate e)
-- | Concrete instance of the interface for value operations.
instance (ArrowClosure Expr Cls c, ArrowChoice c, ArrowFail String c) => IsVal Val (ValueT Val c) where
......
......@@ -119,7 +119,7 @@ evalInterval env0 e = snd $
returnA -< (var,ctx)
iterationStrategy =
-- traceShow .
traceShow .
-- traceCache show .
Ctx.recordCallsite ?sensitivity (\(_,(_,expr)) -> case expr of App _ _ l -> Just l; _ -> Nothing) .
filter apply parallel
......
Copyright (c) 2017-2018, the Sturdy contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Sven Keidel nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
import Distribution.Simple
main = defaultMain
name: sturdy-scheme
version: 0.2.0.0
license: BSD3
maintainer: Sven Keidel <svenkeidel@gmail.com>
category: Language
dependencies:
- base
- hashable
- mtl
- profunctors
- sturdy-lib
- text
- transformers
- unordered-containers
- parsec
- array
- random
- split
- process
- directory
library:
source-dirs:
- src
- parser
- scheme_files
ghc-options: -Wall
tests:
spec:
main: Spec.hs
source-dirs:
- test
ghc-options: -Wall
dependencies:
- sturdy-scheme
- hspec
module LispParser where
import LispTypes
import Control.Monad.Except
import Data.Ratio
import Data.Array
import Numeric
import Text.Parsec.Char hiding (spaces)
import Text.ParserCombinators.Parsec hiding (spaces)
-- |Parse an expression
-- Parse and evaluate a LispVal returning a monadic value
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
Left err -> throwError $ Parser err
Right val -> do
return val
-- |Parse a single expression
readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow mainParser
-- |Parse multiple expressions
readExprList :: String -> ThrowsError [LispVal]
readExprList = readOrThrow (endBy mainParser whitespace)
-- | Discard leading whitespace
mainParser :: Parser LispVal
mainParser = do
skipMany whitespace
skipMany parseComment
parseExpr
-- |Parser that recognizes one of the symbols allowed in Scheme Ident.
symbol :: Parser Char
symbol = oneOf "#!$%&|*/+-:<=?>@^_~"
whitespace :: Parser ()
whitespace = skipMany1 (space <|> tab)
-- |Parser to ignore whitespace
spaces :: Parser ()
spaces = skipMany1 space
parseAtom :: Parser LispVal
parseAtom = do
first <- letter <|> symbol
rest <- many (letter <|> digit <|> symbol)
return $ Atom ( first : rest )
-- |Parse a boolean value
parseBool :: Parser LispVal
parseBool = do
_ <- try $ char '#'
(char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))
-- Exercise 2.2 and 2.3
-- Parse escaped Chars in strings
parseEscapedChars :: Parser Char
parseEscapedChars = do
_ <- char '\\'
x <- oneOf "\\\"nrt"
return $ case x of
'\\' -> x
'"' -> x
'n' -> '\n'
'r' -> '\r'
't' -> '\t'
_ -> x
-- |Parse a string
parseString :: Parser LispVal
parseString = do
_ <- char '"'
x <- many (parseEscapedChars <|> noneOf "\"")
_ <- char '"'
return $ String x
-- |Parse a negative sign Char and return an
-- Integer value to be multiplied to a parsed number
parseIntegerSign :: Parser Integer
parseIntegerSign = do
signChar <- optionMaybe $ oneOf "+-"
return $ case signChar of
Just '-' -> -1
Just '+' -> 1
_ -> 1
-- |Parse a negative sign Char and return an
-- Integer value to be multiplied to a parsed number
parseDoubleSign :: Parser Double
parseDoubleSign = do
signChar <- optionMaybe $ oneOf "+-"
return $ case signChar of
Just '-' -> -1
Just '+' -> 1
_ -> 1
-- |Same as parseDoubleSign but fail if sign is not found
parseDoubleSignStrict :: Parser Double
parseDoubleSignStrict = do
signChar <- optionMaybe $ oneOf "+-"
case signChar of
Just '-' -> return $ -1
Just '+' -> return 1
_ -> fail "no sign"
-- |Parse a Number
{-
Parse many digits (Parser String)
Then apply a LispVal Atom Number constructor
Composed with read to the resulting value
liftM is used to promote the function to a Monad
-}
parseNumber :: Parser LispVal
parseNumber = parseDecimal
<|> parseDecimalExplBasis
<|> parseBinary
<|> parseOctal
<|> parseHexadecimal
parseDecimal :: Parser LispVal
parseDecimal = do
sign <- parseIntegerSign
Number . (*sign) . read <$> many1 digit
parseDecimalExplBasis :: Parser LispVal
parseDecimalExplBasis = do
_ <- try $ string "#d"
sign <- parseIntegerSign
x <- many1 digit
(return . Number . (*sign) . read) x
bin2dig :: [Char] -> Integer
bin2dig = bin2dig' 0
bin2dig' :: Num t => t -> [Char] -> t
bin2dig' dig "" = dig
bin2dig' dig (x:xs) = bin2dig' (2 * dig + (if x == '0'
then 0 else 1)) xs
parseBinary :: Parser LispVal
parseBinary = do
_ <- try $ string "#b"
sign <- parseIntegerSign
x <- many1 $ oneOf "01"
(return . Number . (*sign) . bin2dig) x
parseHexadecimal :: Parser LispVal
parseHexadecimal = do
_ <- try $ string "#x"
sign <- parseIntegerSign
x <- many1 hexDigit
(return . Number . (*sign) . fst . head . readHex) x
-- oct2dig = ()
parseOctal :: Parser LispVal
parseOctal = do
_ <- try $ string "#o"
sign <- parseIntegerSign
x <- many1 octDigit
(return . Number . (*sign) . fst . head . readOct) x
parseFloat :: Parser LispVal
parseFloat = do
sign <- parseDoubleSign
x <- many1 digit
_ <- char '.'
y <- many1 digit
(return . Float . (*sign) . fst . head . readFloat) $ x++"."++y
parseRatio :: Parser LispVal
parseRatio = do
sign <- parseIntegerSign
x <- many1 digit
_ <- char '/'
y <- many1 digit
(return . Ratio) $ ((*sign) . read) x % read y
-- TODO : remove error
-- |Convert a LispVal Float or Integer to Haskell Double
-- toDouble :: LispVal -> Double
-- toDouble (Float f) = realToFrac f
-- toDouble (Number n) = fromIntegral n
-- toDouble _ = error "not a float or integer" --
-- |Parse a Complex Number
-- parseComplex :: Parser LispVal
-- parseComplex = do
-- realSign <- parseDoubleSign
-- realVal <- try parseFloat <|> parseDecimal
-- imagSign <- parseDoubleSignStrict
-- imagVal <- try parseFloat <|> parseDecimal
-- _ <- char 'i'
-- (return . Complex) $ ((*realSign) . toDouble) realVal :+ ((*imagSign) . toDouble) imagVal
parseCharacter :: Parser LispVal
parseCharacter = do
_ <- string "#\\"
value <- try (string "newline" <|> string "space")
<|> do
x <- anyChar
notFollowedBy alphaNum
return [x]
return $ Character $ case value of
"space" -> ' '
"newline" -> '\n'
_ -> head value
-- |Parse an Expression (Either a String, a number or an Atom)
parseExpr :: Parser LispVal
parseExpr = do
expr <- try parseRatio
-- <|> try parseComplex
<|> try parseFloat
<|> try parseNumber
<|> try parseAtom
<|> parseString
<|> try parseBool
<|> try parseCharacter
<|> try parseQuoted
<|> try parseQuasiQuoted
<|> try parseUnQuote
<|> try parseVector
<|> try parseParens
skipMany parseComment
return expr
-- |Parse a List of Atoms like a b c d
parseList :: Parser LispVal
parseList = List <$> sepEndBy parseExpr spaces
-- |Parse a Dotted list (a b c . d)
parseDottedList :: Parser LispVal
parseDottedList = do
-- Parse a List of 0 or more expressions
-- Separated by spaces
head_ <- endBy parseExpr spaces
-- Then parse the remaining Expr after the dot
tail_ <- char '.' >> spaces >> parseExpr
skipMany spaces
return $ DottedList head_ tail_
-- |Parse a Quoted Expression 'a
parseQuoted :: Parser LispVal
parseQuoted = do