From 06bf4c656377572859846767cb9af5db8fc27893 Mon Sep 17 00:00:00 2001
From: Akshay <nerdy@peppe.rs>
Date: Fri, 9 Oct 2020 11:35:56 +0530
Subject: use mtl to generate errors

---
 default.nix      | 15 ++++++++++++---
 lisk.cabal       |  4 +++-
 src/Error.hs     | 31 +++++++++++++++++++++++++++++++
 src/Evaluator.hs | 22 ++++++++++++++--------
 src/Operators.hs | 18 ++++++++++++------
 5 files changed, 72 insertions(+), 18 deletions(-)
 create mode 100644 src/Error.hs

diff --git a/default.nix b/default.nix
index 1890d35..90576e7 100644
--- a/default.nix
+++ b/default.nix
@@ -1,10 +1,19 @@
-{ mkDerivation, base, parsec, readline, stdenv }:
+{ mkDerivation, base, mtl, parsec, QuickCheck, readline, stdenv
+, test-framework, test-framework-hunit, test-framework-quickcheck2
+, test-framework-th
+}:
 mkDerivation {
   pname = "lisk";
   version = "0.1.0.0";
   src = ./.;
-  isLibrary = false;
+  isLibrary = true;
   isExecutable = true;
-  executableHaskellDepends = [ base parsec readline ];
+  libraryHaskellDepends = [ base mtl parsec ];
+  executableHaskellDepends = [ base mtl parsec readline ];
+  testHaskellDepends = [
+    base parsec QuickCheck test-framework test-framework-hunit
+    test-framework-quickcheck2 test-framework-th
+  ];
+  description = "a lisp interpreter";
   license = stdenv.lib.licenses.gpl3;
 }
diff --git a/lisk.cabal b/lisk.cabal
index 627815d..bea3414 100644
--- a/lisk.cabal
+++ b/lisk.cabal
@@ -26,7 +26,8 @@ library
   exposed-modules: 
     Parser,
     Evaluator,
-    Operators
+    Operators,
+    Error
 
 executable lisk
   default-language: Haskell2010
@@ -35,6 +36,7 @@ executable lisk
     base >=4.12 && <4.13,
     parsec == 3.*,
     readline >= 1.0,
+    mtl >= 2.1,
     lisk
   hs-source-dirs: bin
 
diff --git a/src/Error.hs b/src/Error.hs
new file mode 100644
index 0000000..276d3e2
--- /dev/null
+++ b/src/Error.hs
@@ -0,0 +1,31 @@
+module Error (
+             LispError (..)
+             , LispResult (..)
+             , unwrap
+             ) where
+
+import           Control.Monad.Except
+import           Parser
+import           Text.ParserCombinators.Parsec
+
+data LispError = Parse ParseError
+               | BadForm String Expr
+               | ArgCount Int [Expr]
+               | UnknownFunction String
+               | TypeMismatch String Expr
+
+unwordsList :: [Expr] -> String
+unwordsList = unwords . map show
+
+instance Show LispError where
+    show (Parse e)        = "Parser Error: " ++ show e
+    show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr
+    show (ArgCount n es) = "Invalid arity, expected " ++ show n ++ ", got values: " ++ unwordsList es
+    show (UnknownFunction fn) = "Unknown reference to function: " ++ fn
+    show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got
+
+type LispResult = Either LispError
+
+unwrap :: LispResult t -> t
+unwrap (Right v) = v
+unwrap (Left _)  = undefined -- should panic
diff --git a/src/Evaluator.hs b/src/Evaluator.hs
index f264ee0..28ee79b 100644
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -2,21 +2,27 @@ module Evaluator (
     eval
     ) where
 
+import           Control.Monad.Except
+import           Error                         (LispError (..), LispResult (..),
+                                                unwrap)
 import           Operators
 import           Parser
 import           Text.ParserCombinators.Parsec
 
-apply :: String -> [Expr] -> Expr
+apply :: String -> [Expr] -> LispResult Expr
 apply fn args =
     case lookup fn primitives of
       Just f -> f args
-      _      -> BoolLiteral False -- TODO: error out instead
+      _      -> throwError $ UnknownFunction fn
 
-eval :: Expr -> Expr
-eval v@(StringLiteral s)     = v
-eval v@(IntLiteral i)        = v
-eval v@(BoolLiteral b)       = v
+eval :: Expr -> LispResult Expr
+eval v@(StringLiteral s)     = return v
+eval v@(IntLiteral i)        = return v
+eval v@(BoolLiteral b)       = return v
 -- handle quotes as literals
-eval (List[Id "quote", val]) = val
-eval (List (Id fn : args))   = apply fn $ map eval args
+eval (List[Id "quote", val]) = return val
+eval (List (Id fn : args))   = mapM eval args >>= apply fn
+
+-- handle bad forms
+eval idk = throwError $ BadForm "lisk can't recognize this form" idk
 
diff --git a/src/Operators.hs b/src/Operators.hs
index e57f885..3b96281 100644
--- a/src/Operators.hs
+++ b/src/Operators.hs
@@ -2,9 +2,11 @@ module Operators (
     primitives
     ) where
 
+import           Control.Monad.Except
+import           Error                (LispError (..), LispResult (..))
 import           Parser
 
-primitives :: [(String, [Expr] -> Expr)]
+primitives :: [(String, [Expr] -> LispResult Expr)]
 primitives =
     [
     ("+", arithmetic (+))
@@ -13,10 +15,14 @@ primitives =
     , ("/", arithmetic div)
     ]
 
-arithmetic :: (Integer -> Integer -> Integer) -> [Expr] -> Expr
-arithmetic op args = IntLiteral $ foldl1 op $ map unwrapNum args
+arithmetic :: (Integer -> Integer -> Integer) -> [Expr] -> LispResult Expr
+arithmetic op args
+    | length args < 2 = throwError $ ArgCount 2 args
+    | otherwise = do
+        as <- mapM unwrapNum args
+        return . IntLiteral $ foldl1 op as
 
-unwrapNum :: Expr -> Integer
-unwrapNum (IntLiteral n) = n
-unwrapNum _              = undefined
+unwrapNum :: Expr -> LispResult Integer
+unwrapNum (IntLiteral n) = return n
+unwrapNum x              = throwError $ TypeMismatch "number" x
 
-- 
cgit v1.2.3