Scheme Boi

Functions.hs

module Functions where
    
import SExpr

mathF :: (Integer -> Integer -> Integer) -> String -> Literal -> Literal -> Literal
mathF op s (LNum a) (LNum b) = LNum $ a `op` b
mathF _ s _ _ = error $ "Non number passed to " ++ s

addF :: Literal -> Literal -> Literal
addF a b = mathF (+) "+" a b

subF :: Literal -> Literal -> Literal
subF a b = mathF (-) "-" a b

mulF :: Literal -> Literal -> Literal
mulF a b = mathF (*) "*" a b

Parser.hs

{-# LANGUAGE OverloadedStrings #-}

module Parser where

import qualified Data.Text as T
import Data.Void
import Control.Applicative hiding (some, many)
import Text.Megaparsec
import Text.Megaparsec.Char

import SExpr

type Parser = Parsec Void T.Text

parseNum :: Parser Literal
parseNum = (some digitChar) >>= (return . LNum . read)
parseIdent :: Parser Literal
parseIdent = (some $ noneOf ("() '\"\n\t" :: String)) >>= (return . LIdent)
parseQuote :: Parser Literal
parseQuote = LQuote <$> (char '\'' *> parseSExpr)

parseSExprUnit :: Parser SExpr
parseSExprUnit = (SLiteral <$> (parseNum <|> parseIdent <|> parseQuote)) <|> parseSExpr
parseSExpr :: Parser SExpr
parseSExpr = do
    _ <- char '('
    expr <- sepBy1 (parseSExprUnit) (space)
    _ <- char ')'
    return $ SExpr expr

Reduce.hs

module Reduce where
    
import SExpr
import Functions

import Data.Maybe

flattenSExpr :: [SExpr] -> Maybe [Literal]
flattenSExpr = mapM isLiteral
    where
        isLiteral s = case s of
            SExpr _ -> Nothing
            SLiteral l -> Just l

apply :: [Literal] -> IO (Maybe Literal)
apply ((LIdent s):ss) = case s of
    "+" -> return . Just $ foldr (addF) (LNum 0) ss
    "-" -> return . Just $ foldr (subF) (LNum 0) ss
    "*" -> return . Just $ foldr (mulF) (LNum 1) ss
    "print" -> putStrLn s >> (return Nothing)
    otherwise -> error $ "Can't find function " ++ s ++ "."
apply (_:ss) = error "S-Expression did not begin with a function."

reduce :: SExpr -> IO (Maybe SExpr)
reduce e@(SLiteral s) = return . Just $ e
reduce (SExpr s) = 
    case (flattenSExpr s) of
        Just flat -> do
            applied <- apply flat
            case (applied) of
                l@(Just _) -> return $ SLiteral <$> l
                Nothing -> return Nothing
        Nothing -> do
            s' <- sequence $ reduce <$> s
            return . Just $ SExpr (catMaybes s')

SExpr.hs

module SExpr where

data Literal = LNum Integer | LString String | LIdent String | LQuote SExpr deriving (Show)

data SExpr = SExpr [SExpr] | SLiteral Literal deriving (Show)