From 684e09298b8453ee56571d8a225e11d7c57e3746 Mon Sep 17 00:00:00 2001
From: Akshay <nerdy@peppe.rs>
Date: Thu, 15 Oct 2020 21:37:00 +0530
Subject: add basic list primitives

---
 src/Operators.hs    | 58 +++++++++++++++++++++++++++++++++++++++++------------
 tests/Properties.hs |  4 ++--
 2 files changed, 47 insertions(+), 15 deletions(-)

diff --git a/src/Operators.hs b/src/Operators.hs
index 051655a..c5812ea 100644
--- a/src/Operators.hs
+++ b/src/Operators.hs
@@ -9,19 +9,23 @@ import           Parser
 primitives :: [(String, [Expr] -> LispResult Expr)]
 primitives = map (\(n, f) -> (n, f n))
     [
-           ("+" , arithmetic (+))
-         , ("-" , arithmetic (-))
-         , ("*" , arithmetic (*))
-         , ("/" , arithmetic (/))
-         , (">" , comparator (>))
-         , ("<" , comparator (<))
-         , (">=" , comparator (>=))
-         , ("<=" , comparator (<=))
-         , ("=" , comparator (==))
-         , ("!=" , comparator (/=))
-         , ("not" , unaryBool not)
-         , ("or" , naryBool  (||))
-         , ("and" , naryBool  (&&))
+    ("+", arithmetic (+))
+    , ("-", arithmetic (-))
+    , ("*", arithmetic (*))
+    , ("/", arithmetic (/))
+    , (">", comparator (>))
+    , ("<", comparator (<))
+    , (">=", comparator (>=))
+    , ("<=", comparator (<=))
+    , ("=" , comparator (==))
+    , ("!=" , comparator (/=))
+    , ("not", unaryBool not)
+    , ("or", naryBool  (||))
+    , ("and", naryBool  (&&))
+    , ("car", car)
+    , ("cdr", cdr)
+    , ("cons", cons)
+    , ("null?", isNull)
     ]
 
 data LispNumber = I Integer
@@ -90,3 +94,31 @@ wrapNum (F n) = FloatLiteral n
 unwrapBool :: Expr -> LispResult Bool
 unwrapBool (BoolLiteral s) = return s
 unwrapBool x               = throwError $ TypeMismatch "boolean" x
+
+-- list primitives
+
+car :: FName -> [Expr] -> LispResult Expr
+car _ [List (x:xs)]          = return x
+car _ [DottedList (x:xs) _ ] = return x
+car _ [somethingElse]        = throwError $ TypeMismatch "pair" somethingElse
+car fn mulArgs               = throwError $ ArgCount fn 1 mulArgs
+
+cdr :: FName -> [Expr] -> LispResult Expr
+cdr _ [List (x:xs)]         = return $ List xs
+cdr _ [DottedList [_] tail] = return tail
+cdr _ [DottedList (_:xs) t] = return $ DottedList xs t
+cdr _ [somethingElse]       = throwError $ TypeMismatch "pair" somethingElse
+cdr fn mulArgs              = throwError $ ArgCount fn 1 mulArgs
+
+cons :: FName -> [Expr] -> LispResult Expr
+cons _ [val, List []]            = return $ List [val]
+cons _ [val, List ls]            = return $ List $ val:ls
+cons _ [val, DottedList ls tail] = return $ DottedList (val:ls) tail
+cons _ [v1, v2]                  = return $ DottedList [v1] v2
+cons fn mulArgs                  = throwError $ ArgCount fn 2 mulArgs
+
+isNull :: FName -> [Expr] -> LispResult Expr
+isNull _ [List []] = return $ BoolLiteral True
+isNull _ [List _]  = return $ BoolLiteral False
+isNull _ [arg]     = throwError $ TypeMismatch "pair" arg
+isNull fn args     = throwError $ ArgCount fn 1 args
diff --git a/tests/Properties.hs b/tests/Properties.hs
index b9550c0..03a7e9a 100644
--- a/tests/Properties.hs
+++ b/tests/Properties.hs
@@ -10,8 +10,6 @@ import           Operators       (primitives)
 import           Parser          (Expr (..), parseLispValue, parseQuote)
 import           Test.QuickCheck
 
-addition = fromJust $ lookup "+" primitives
-multiplication = fromJust $ lookup "*" primitives
 
 prop_commutativeAdd :: [Integer] -> Property
 prop_commutativeAdd xs =
@@ -19,6 +17,7 @@ prop_commutativeAdd xs =
         where rhs = (unwrap . addition) exprs
               lhs = (unwrap . addition . reverse) exprs
               exprs = map IntLiteral xs
+              addition = fromJust $ lookup "+" primitives
 
 prop_commutativeMul :: [Integer] -> Property
 prop_commutativeMul xs =
@@ -26,6 +25,7 @@ prop_commutativeMul xs =
         where rhs = (unwrap . multiplication) exprs
               lhs = (unwrap . multiplication . reverse) exprs
               exprs = map IntLiteral xs
+              multiplication = fromJust $ lookup "*" primitives
 
 return []
 runTests = $quickCheckAll
-- 
cgit v1.2.3