Refactoring

Author: lucasimi

app/Main.hs

@@ -5,13 +5,15 @@ import System.Environment
 import System.Console.Haskeline
 import Control.Monad.IO.Class
 
-import Interpreter
-import Parser
-import SExpr
+import Data.ParseTree
+import Data.Compiler
+import Data.SExpr
+import Interpreter.Eval
+import Runtime.Effect
 import Utils
 
 -- Read input from keyboard
-readInputFragment :: String -> Int -> InputT IO (Maybe TokenTree)
+readInputFragment :: String -> Int -> InputT IO (Maybe ParseTree)
 readInputFragment str lines = do
   input <- getInputLine $ "[" ++ show lines ++ "]> "
            ++ (concat $ replicate open "\t")
@@ -22,7 +24,7 @@ readInputFragment str lines = do
     Just str' -> case isBlank str' of
       True -> readInputFragment str lines
       False -> case numberOfOpenBrackets False (str ++ " " ++ str') >= 0 of
-        True -> case reads (str ++ " " ++ str') :: [(TokenTree, String)] of
+        True -> case reads (str ++ " " ++ str') :: [(ParseTree, String)] of
           [] -> readInputFragment (str ++ " " ++ str') (lines + 1)
           [(tree, str'')] -> case isBlank str'' of
             True -> liftIO $ return $ Just tree
@@ -31,7 +33,7 @@ readInputFragment str lines = do
   where
     open = numberOfOpenBrackets False str
 
-readInput :: InputT IO (Maybe TokenTree)
+readInput :: InputT IO (Maybe ParseTree)
 readInput = readInputFragment "" 0
 
 -- read-eval-print-loop for terminal

minilisp.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8041b3b29d2e32ff95bde03f5a127e8844379ed7b96a3f64a33619a1d62394cf
+-- hash: a94600b5544fc2d8153c9072d05a8d5b75f1eec3ecbf19ac8191a561d1585b64
 
 name:           minilisp
 version:        0.1.0.0
@@ -26,9 +26,13 @@ source-repository head
 
 library
   exposed-modules:
-      Interpreter
-      Parser
-      SExpr
+      Data.Compiler
+      Data.ParseTree
+      Data.SExpr
+      Data.Token
+      Interpreter.Eval
+      Runtime.Effect
+      Runtime.Error
       Utils
   other-modules:
       Paths_minilisp
@@ -62,8 +66,8 @@ test-suite minilisp-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
-      InterpreterTest
-      ParserTest
+      CompilerTest
+      EvalTest
       Paths_minilisp
   hs-source-dirs:
       test

src/Parser.hs src/Data/Compiler.hs

@@ -1,65 +1,13 @@
-module Parser where
+module Data.Compiler where
 
 import qualified Data.Map as Map
 
-import SExpr
+import Data.SExpr
+import Data.Token
+import Data.ParseTree
 import Utils
 
-data Token = IntegerType Integer
-           | DoubleType Double
-           | BoolType Bool
-           | StringType String
-           | SymbType String
-           deriving (Show, Eq)
-
-data TokenTree = Empty
-              | Leaf Token
-              | Node TokenTree TokenTree deriving (Show, Eq)
-
-instance Read Token where
-  readsPrec _ str = case dropLeadingBlanks str of
-    "" -> []
-    '(':_ -> []
-    ')':_ -> []
-    '.':_ -> []
-    str' -> case reads str' :: [(String, String)] of
-      [(x, s)] -> [(StringType x, s)]
-      _ -> case reads str' :: [(Integer, String)] of
-        [(x, s)] -> [(IntegerType x, s)]
-        _ -> case reads str' :: [(Double, String)] of
-          [(x, s)] -> [(DoubleType x, s)]
-          _ -> case split str' of
-            ("#t", s) -> [(BoolType True, s)]
-            ("#f", s) -> [(BoolType False, s)]
-            ('\"':_, _) -> [] -- a symbol cannot begin with a double quote
-            (str'', s) -> [(SymbType str'', s)]
-
-instance Read TokenTree where
-  readsPrec _ str = case dropLeadingBlanks str of
-    "" -> []
-    ')':_ -> []
-    '.':_ -> []
-    '\'':str' -> case reads str' :: [(TokenTree, String)] of
-      [(x, str'')] -> [(Node (Leaf (SymbType "\'")) (Node x Empty), str'')]
-      _ -> [(Empty, '\'':str')]
-    '(':str' -> case dropLeadingBlanks str' of
-      ')':str'' -> [(Empty, str'')]
-      _ -> case reads str' :: [(TokenTree, String)] of
-        [(x, str'')] -> case dropLeadingBlanks str'' of
-          "" -> []
-          ')':str''' -> [(Node x Empty, str''')]
-          '.':str''' -> case reads ('(':str''') :: [(TokenTree, String)] of
-            [(Node y Empty, str'''')] -> [(Node x y, str'''')]
-            _ -> []
-          _ -> case reads ('(':str'') :: [(TokenTree, String)] of
-            [(y, str''')] -> [(Node x y, str''')]
-            _ -> []
-        _ -> []
-    _ -> case reads str :: [(Token, String)] of
-      [(x, str')] -> [(Leaf x, str')]
-      _ -> []
-
-compile :: TokenTree -> Maybe SExpr
+compile :: ParseTree -> Maybe SExpr
 compile Empty = Just Nil
 
 compile (Leaf (BoolType True)) = Just T
@@ -196,15 +144,15 @@ compile (Node x y) = do
   y' <- compile y
   return $ Pair x' y'
 
-compileList :: TokenTree -> Maybe [SExpr]
+compileList :: ParseTree -> Maybe [SExpr]
 compileList Empty = Just []
 compileList (Node x y) = do
   x' <- compile x
   y' <- compileList y
   return (x':y')
 compileList _ = Nothing
 
-compileCoupleList :: TokenTree -> Maybe [(SExpr, SExpr)]
+compileCoupleList :: ParseTree -> Maybe [(SExpr, SExpr)]
 compileCoupleList Empty = Just []
 compileCoupleList (Node (Node x (Node y Empty)) z) = do
   x' <- compile x

src/Data/ParseTree.hs

@@ -0,0 +1,33 @@
+module Data.ParseTree where
+
+import Data.Token
+import Utils
+
+data ParseTree = Empty
+               | Leaf Token
+               | Node ParseTree ParseTree deriving (Show, Eq)
+
+instance Read ParseTree where
+  readsPrec _ str = case dropLeadingBlanks str of
+    "" -> []
+    ')':_ -> []
+    '.':_ -> []
+    '\'':str' -> case reads str' :: [(ParseTree, String)] of
+      [(x, str'')] -> [(Node (Leaf (SymbType "\'")) (Node x Empty), str'')]
+      _ -> [(Empty, '\'':str')]
+    '(':str' -> case dropLeadingBlanks str' of
+      ')':str'' -> [(Empty, str'')]
+      _ -> case reads str' :: [(ParseTree, String)] of
+        [(x, str'')] -> case dropLeadingBlanks str'' of
+          "" -> []
+          ')':str''' -> [(Node x Empty, str''')]
+          '.':str''' -> case reads ('(':str''') :: [(ParseTree, String)] of
+            [(Node y Empty, str'''')] -> [(Node x y, str'''')]
+            _ -> []
+          _ -> case reads ('(':str'') :: [(ParseTree, String)] of
+            [(y, str''')] -> [(Node x y, str''')]
+            _ -> []
+        _ -> []
+    _ -> case reads str :: [(Token, String)] of
+      [(x, str')] -> [(Leaf x, str')]
+      _ -> []

src/SExpr.hs src/Data/SExpr.hs

@@ -1,4 +1,4 @@
-module SExpr where
+module Data.SExpr where
 
 data SExpr = Nil
            | T
@@ -57,7 +57,6 @@ instance Show SExpr where
           isList (Pair x y) = isList y
           isList _ = False
   show (Lambda _ _) = "<function>"
-
   show (CAR x) = "(car " ++ show x ++ ")"
   show (CDR x) = "(cdr " ++ show x ++ ")"
   show (CONS x y) = "(cons " ++ show x ++ " " ++ show y ++ ")"
@@ -73,11 +72,10 @@ instance Show SExpr where
   show (OR x) = "(or " ++ showSExprList x ++ ")"
   show (AND x) = "(and " ++ showSExprList x ++ ")"
   show (LIST x) = "(list " ++ showSExprList x ++ ")"
-  show (COND x) = "(cond " ++ showSExprPairList ++ ")"
+  show (COND x) = "(cond " ++ showSExprPairList x ++ ")"
   show (IF x y z) = "(if " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")"
   show (LABEL x y) = "(label " ++ show x ++ " " ++ show y ++ ")"
   show (LET x y z) = "(let " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")"
   show (DEFINE x y) = "(define " ++ show x ++ " " ++ show y ++ ")"
   show (MOD x y) = "(% " ++ show x ++ " " ++ show y ++ ")"
   show (NOT x) = "(not " ++ show x ++ ")"
-  show _ = "<unevaluated>"

src/Data/Token.hs

@@ -0,0 +1,28 @@
+module Data.Token where
+
+import Utils
+
+data Token = IntegerType Integer
+           | DoubleType Double
+           | BoolType Bool
+           | StringType String
+           | SymbType String
+           deriving (Show, Eq)
+
+instance Read Token where
+ readsPrec _ str = case dropLeadingBlanks str of
+   "" -> []
+   '(':_ -> []
+   ')':_ -> []
+   '.':_ -> []
+   str' -> case reads str' :: [(String, String)] of
+     [(x, s)] -> [(StringType x, s)]
+     _ -> case reads str' :: [(Integer, String)] of
+       [(x, s)] -> [(IntegerType x, s)]
+       _ -> case reads str' :: [(Double, String)] of
+         [(x, s)] -> [(DoubleType x, s)]
+         _ -> case split str' of
+           ("#t", s) -> [(BoolType True, s)]
+           ("#f", s) -> [(BoolType False, s)]
+           ('\"':_, _) -> [] -- a symbol cannot begin with a double quote
+           (str'', s) -> [(SymbType str'', s)]

src/Interpreter.hs src/Interpreter/Eval.hs

@@ -1,56 +1,12 @@
-module Interpreter where
+module Interpreter.Eval where
 
 import qualified Data.Map as Map
 
-import SExpr
+import Data.SExpr
+import Runtime.Error
+import Runtime.Effect
 import Utils
 
--- error data type
-data Error = RuntimeError String
-           | UnexpectedArgNumError Integer
-           | UnexpectedValueError SExpr
-           | UnboundSymbolError String
-           | DivisionByZeroError
-           | UnexpectedExpressionError SExpr
-           deriving Show
-
--- monad which wraps effectful computations (which may fail)
-data Effect a = Effect (IO (Either Error a))
-
-instance Functor Effect where
-  fmap f (Effect x) = Effect $ do
-    x' <- x
-    case x' of
-      Left err -> do
-        return $ Left err
-      Right a -> return $ Right $ f a
-
-instance Applicative Effect where
-  pure a = Effect $ return $ Right a
-
-  (Effect f) <*> (Effect x) = Effect $ do
-    x' <- x
-    case x' of
-      Left errx -> do
-        return $ Left errx
-      Right a -> do
-        f' <- f
-        case f' of
-          Left errf -> do
-            return $ Left errf
-          Right g -> return $ Right $ g a
-
-instance Monad Effect where
-  (Effect x) >>= f = Effect $ do
-    x' <- x
-    case x' of
-      Left err -> do
-        return $ Left err
-      Right a -> do
-        let Effect y = f a
-        y' <- y
-        return y'
-
 -- environment data type, where variables are stored
 type Env = Map.Map String SExpr
 type Ctx = [Env]

src/Runtime/Effect.hs

@@ -0,0 +1,40 @@
+module Runtime.Effect where
+
+import Runtime.Error
+
+-- monad which wraps effectful computations (which may fail)
+data Effect a = Effect (IO (Either Error a))
+
+instance Functor Effect where
+  fmap f (Effect x) = Effect $ do
+    x' <- x
+    case x' of
+      Left err -> do
+        return $ Left err
+      Right a -> return $ Right $ f a
+
+instance Applicative Effect where
+  pure a = Effect $ return $ Right a
+
+  (Effect f) <*> (Effect x) = Effect $ do
+    x' <- x
+    case x' of
+      Left errx -> do
+        return $ Left errx
+      Right a -> do
+        f' <- f
+        case f' of
+          Left errf -> do
+            return $ Left errf
+          Right g -> return $ Right $ g a
+
+instance Monad Effect where
+  (Effect x) >>= f = Effect $ do
+    x' <- x
+    case x' of
+      Left err -> do
+        return $ Left err
+      Right a -> do
+        let Effect y = f a
+        y' <- y
+        return y'

src/Runtime/Error.hs

@@ -0,0 +1,12 @@
+module Runtime.Error where
+
+import Data.SExpr
+
+-- error data type
+data Error = RuntimeError String
+           | UnexpectedArgNumError Integer
+           | UnexpectedValueError SExpr
+           | UnboundSymbolError String
+           | DivisionByZeroError
+           | UnexpectedExpressionError SExpr
+           deriving Show