{-# OPTIONS -Wall #-}
module Lambda where

import Data.Map.Strict (Map,fromList,insert)
import qualified Data.Map.Strict as Map
import Text.Show.Functions ()
import Data.Maybe

data Token = Accent | Name String | Hash | Num Int
  deriving (Show)

isChar :: Char -> Bool
isChar c = 'a'<=c && c<= 'z' || 'A'<=c && c<= 'Z'

lexer :: String -> [Token]
lexer (' ':ss) = lexer ss
lexer ('`':ss) = Accent:lexer ss
lexer ('#':ss) = Hash:lexer ss
lexer [] = []
lexer (c:ss) | '0'<=c && c<= '9' = (Num $ read num):lexer rest1
             | isChar c = (Name w):lexer rest2
  where
    (num,rest1)=number (c:ss)
    (w,rest2)=word (c:ss)
lexer _ = error "This should never happen"

readSequence :: (a -> Bool) -> [a] -> ([a],[a])
readSequence p (x:xs) | p x = (x:(rest_seq),rest_string)
                      | otherwise = ([],(x:xs))
  where (rest_seq,rest_string) = (readSequence p xs)
readSequence _ [] = ([],[])

number :: String->(String,String)
number = readSequence (\c-> c>='0' && c<='9')

word :: String -> (String,String)
word = readSequence isChar

data Expr = Abstraction String Expr | Var String |  Application Expr Expr | Val Int
  deriving (Show)

parser :: [Token] -> Expr
parser = fst . parser'
parser':: [Token] -> (Expr,[Token])
parser' (Accent:ts) = (Application f x,rest')
  where
    (x, rest')= parser' rest
    (f, rest) = parser' ts
parser' (Hash:Name s:ts) = (Abstraction s e,rest)
  where (e,rest) = parser' ts
parser' (Name s:ts) = (Var s,ts)
parser' (Num s:ts) = (Val s,ts)
parser' []  = error "expected more"
parser' _ = error "e"

data Value = VInt Int | VFun (Value -> Value)
  deriving (Show)

createOperator :: (Int->Int->Int) -> Value
createOperator op = VFun (\(VInt i) -> VFun (\(VInt j) -> VInt $ i `op` j)) 
addf :: Value
addf = createOperator (+)
mulf :: Value
mulf = createOperator (*)

eval :: Expr -> Value
eval = eval' $ fromList [("add",addf),("mul",mulf)]

eval' :: Map String Value -> Expr -> Value
eval' m (Abstraction s e) = VFun f
  where f x = eval' (insert s x m) e
eval' m (Var s) = fromJust $ Map.lookup s m
eval' m (Application e1 e2) = f x
  where 
    VFun f = eval' m e1
    x = eval' m e2
eval' _ (Val i) = VInt i

interpret :: String -> Value
interpret = eval . parser . lexer