Small-Step Implementation

import Data.Char

data Arith_Expr = Num Int
    | PlusE Arith_Expr Arith_Expr
    | TimesE Arith_Expr Arith_Expr
    | LetE String Arith_Expr Arith_Expr
    | VarE String
  deriving Show


step :: Arith_Expr -> Maybe Arith_Expr
step (Num n) = Nothing
step (VarE _) = Nothing
step (PlusE (Num v1) (Num v2)) = Just (Num (v1 + v2))
step (PlusE (Num v1) e2) = case step e2 of
    Nothing -> Nothing
    Just e2_2 -> Just (PlusE (Num v1) e2_2)
step (PlusE e1 e2) = case step e1 of
    Nothing -> Nothing
    Just e1_2 -> Just (PlusE e1_2 e2)
step (TimesE (Num v1) (Num v2)) = Just (Num (v1 + v2))
step (TimesE (Num v1) e2) = case step e2 of
    Nothing -> Nothing
    Just e2_2 -> Just (TimesE (Num v1) e2_2)
step (TimesE e1 e2) = case step e1 of
    Nothing -> Nothing
    Just e1_2 -> Just (TimesE e1_2 e2)
step (LetE nm (Num v1) e2) = Just (subst nm (Num v1) e2)
step (LetE nm e1 e2) = case step e1 of
    Nothing -> Nothing
    Just e1_2 -> Just (LetE nm e1_2 e2)

steps :: Arith_Expr -> [Arith_Expr]
steps e = case step e of
    Nothing -> [e]
    Just e2 -> e : (steps e2)



-- substitute x for variables named nm in y
subst :: String -> Arith_Expr -> Arith_Expr -> Arith_Expr
subst nm x y = case y of
  Num _ -> y
  PlusE a b -> PlusE (subst nm x a) (subst nm x b)
  TimesE a b -> TimesE (subst nm x a) (subst nm x b)
  LetE nm2 a b -> LetE nm2 (subst nm x a)
    (if nm == nm2 then b else subst nm x b)
  VarE nm2 -> if nm == nm2 then x else y


data Token = LitT Int
  | LParenT | RParenT
  | EqualsT | PlusT | TimesT
  | LetT | InT | VarT String
  deriving Show

lexer :: String -> [Token]
lexer ('(' : cs) = LParenT : lexer cs
lexer (')' : cs) = RParenT : lexer cs
lexer ('+' : cs) = PlusT : lexer cs
lexer ('*' : cs) = TimesT : lexer cs
lexer ('=' : cs) = EqualsT : lexer cs
lexer [] = []
lexer (c : cs) = if isSpace c then lexer cs
  else if isDigit c
  then let (int_string, rest) = break (not . isDigit) (c : cs)
       in (LitT (read int_string) : lexer rest)
  else if isAlpha c
  then let (ident_str, rest) = break isSpace (c : cs)
       in (token_of_ident ident_str : lexer rest)
  else error ("couldn't lex this: " ++ show (c : cs))

token_of_ident s = if s == "let" then LetT else if s == "in" then InT
    else VarT s

parser_atom :: [Token] -> (Arith_Expr, [Token])
parser_atom (LitT i : ts) = (Num i, ts)
parser_atom (VarT nm : ts) = (VarE nm, ts)
parser_atom (LParenT : ts) =
    let (expr, ts2) = parser_lexpr ts
    in case ts2 of
        RParenT : ts3 -> (expr, ts3)
        ts3 -> error ("expecting right parenthesis at: " ++ show ts3)
parser_atom ts = error ("not an atomic expression: " ++ show ts)

parser_pexpr :: [Token] -> (Arith_Expr, [Token])
parser_pexpr ts =
    let (expr, ts2) = parser_atom ts
    in case ts2 of
        TimesT : ts3 ->
            let (expr2, ts4) = parser_pexpr ts3
            in (TimesE expr expr2, ts4)
        _ -> (expr, ts2)

parser_sexpr :: [Token] -> (Arith_Expr, [Token])
parser_sexpr ts =
    let (expr, ts2) = parser_pexpr ts
    in case ts2 of
        PlusT : ts3 ->
            let (expr2, ts4) = parser_sexpr ts3
            in (PlusE expr expr2, ts4)
        _ -> (expr, ts2)

parser_lexpr :: [Token] -> (Arith_Expr, [Token])
parser_lexpr (LetT : VarT nm : EqualsT : ts) =
    let (a, b) = error "matched a let _ = beginning" in
    let (expr, ts2) = parser_sexpr ts
    in case ts2 of
        InT : ts3 ->
            let (expr2, ts4) = parser_sexpr ts3
            in (LetE nm expr expr2, ts4)
        ts3 -> error ("expecting 'in' token at: " ++ show ts3)
parser_lexpr ts = parser_sexpr ts

parser :: String -> Arith_Expr
parser s = case parser_lexpr (lexer s) of
  (expr, []) -> expr
  (expr, ts) -> error ("left-over tokens after parsing: " ++ show ts)