-------------------------------------------                               -- 001
-- Simple Functional Language (a variation)                               -- 002
-------------------------------------------                               -- 003
                                                                          -- 004
                                                                          -- 005
-- variables are just names                                               -- 006
type Var = String                                                         -- 007
                                                                          -- 008
-- values are integers and functions                                      -- 009
data Value = ValInt Integer                                               -- 010
           | ValFunc (Value -> Value)                                     -- 011
           | ValError String                                              -- 012
                                                                          -- 013
                                                                          -- 014
-- an Environment maps variables to Values                                -- 015
type Env = Var -> Value                                                   -- 016
                                                                          -- 017
                                                                          -- 018
-- auxiliary function to map Values to Booleans                           -- 019
isTrue :: Value -> Bool                                                   -- 020
isTrue (ValInt i) = (i /= 0)                                              -- 021
                                                                          -- 022
                                                                          -- 023
-- An empty Environment                                                   -- 024
emptyEnv :: Env                                                           -- 025
emptyEnv v = ValError ("undefined variable " ++ v)                        -- 026
                                                                          -- 027
                                                                          -- 028
-- bind a new value in an environment                                     -- 029
bind :: Var -> Value -> Env -> Env                                        -- 030
bind var val env = \v -> if var == v then val else env v                  -- 031
                                                                          -- 032
                                                                          -- 033
-- build or propagate an error                                            -- 034
mkerr :: Value -> Value -> String -> Value                                -- 035
mkerr e1@(ValError _) _ _ = e1                                            -- 036
mkerr _ e2@(ValError _) _ = e2                                            -- 037
mkerr _ _ msg = ValError msg                                              -- 038
                                                                          -- 039
                                                                          -- 040
-- executes a binary operation on values                                  -- 041
binOp :: (Integer -> Integer -> Integer) -> Value -> Value -> Value       -- 042
binOp op (ValInt i1) (ValInt i2) = ValInt (op i1 i2)                      -- 043
binOp _ v1 v2 = mkerr v1 v2 "binary operand is not a number"              -- 044
                                                                          -- 045
                                                                          -- 046
fix :: (a -> a) -> a                                                      -- 047
fix f = x where x = f x                                                   -- 048
                                                                          -- 049
--------------------------------------------------------------------      -- 050
-- Abstract Syntax Tree for Expressions                                   -- 051
data Exp = ExpN Integer          -- constants                             -- 052
         | ExpVar Var            -- variables                             -- 053
         | ExpAdd Exp Exp        -- e1 + e2                               -- 054
         | ExpSub Exp Exp        -- e1 - e2                               -- 055
         | ExpMul Exp Exp        -- e1 * e2                               -- 056
         | ExpDiv Exp Exp        -- e1 / e2                               -- 057
         | ExpIf Exp Exp Exp     -- if e1 then e2 else e3                 -- 058
         | ExpApp Exp Exp        -- e1 e2                                 -- 059
         | ExpLambda Var Exp     -- \x -> e                               -- 060
         | ExpLetrec Var Exp Exp    -- letrec x=e1 in e2                  -- 061
                                                                          -- 062
-- Evaluates an expression in a given environment                         -- 063
evalExp :: Exp -> Env -> Value                                            -- 064
                                                                          -- 065
evalExp (ExpN i) env = ValInt i                                           -- 066
evalExp (ExpVar v) env = env v                                            -- 067
evalExp (ExpAdd e1 e2) env = binOp (+) (evalExp e1 env) (evalExp e2 env)  -- 068
evalExp (ExpSub e1 e2) env = binOp (-) (evalExp e1 env) (evalExp e2 env)  -- 069
evalExp (ExpMul e1 e2) env = binOp (*) (evalExp e1 env) (evalExp e2 env)  -- 070
evalExp (ExpDiv e1 e2) env = binOp div (evalExp e1 env) (evalExp e2 env)  -- 071
evalExp (ExpIf e1 e2 e3) env =                                            -- 072
    if isTrue(evalExp e1 env) then evalExp e2 env else evalExp e3 env     -- 073
evalExp (ExpApp e1 e2) env = app (evalExp e1 env) (evalExp e2 env)        -- 074
  where app (ValFunc f) x = f x                                           -- 075
        app nf x = mkerr nf x "not a function"                            -- 076
evalExp (ExpLambda v e) env = ValFunc (\x -> evalExp e (bind v x env))    -- 077
                                                                          -- 078
evalExp (ExpLetrec v e1 e2) env = evalExp e2 env'                         -- 079
  where env' = bind v (evalExp e1 env') env                               -- 080
                                                                          -- 081
                                                                          -- 082
---------------------------------------------------------------------------- 083
-------------------------------------------------------------------       -- 084
-- some examples                                                          -- 085
                                                                          -- 086
-- letrec f = \x -> if x then x * f(x - 1) else 1                         -- 087
-- in f 10                                                                -- 088
fat =                                                                     -- 089
  ExpLetrec "f"                                                           -- 090
    (ExpLambda "x"                                                        -- 091
       (ExpIf (ExpVar "x")                                                -- 092
              (ExpMul (ExpVar "x")                                        -- 093
                      (ExpApp (ExpVar "f") (ExpSub (ExpVar "x") (ExpN 1))))-- 094
              (ExpN 1)))                                                  -- 095
    (ExpApp (ExpVar "f") (ExpN 10))                                       -- 096
                                                                          -- 097
                                                                          -- 098
-- y = \f -> (\x -> f (x x)) (\x -> f (x x))                              -- 099
y = ExpLambda "f" (ExpApp y' y')                                          -- 100
  where y' = ExpLambda "x"                                                -- 101
               (ExpApp (ExpVar "f") (ExpApp (ExpVar "x") (ExpVar "x")))   -- 102
                                                                          -- 103
-- fatG = \f -> \x -> if x then x * f(x - 1) else 1                       -- 104
fatG =                                                                    -- 105
  ExpLambda "f"                                                           -- 106
    (ExpLambda "x"                                                        -- 107
       (ExpIf (ExpVar "x")                                                -- 108
              (ExpMul (ExpVar "x")                                        -- 109
                      (ExpApp (ExpVar "f") (ExpSub (ExpVar "x") (ExpN 1))))-- 110
              (ExpN 1)))                                                  -- 111
                                                                          -- 112
-- fat' = (y fatG) 20                                                     -- 113
fat' = ExpApp (ExpApp y fatG) (ExpN 20)                                   -- 114
                                                                          -- 115
-- code to show the final value of an expression                          -- 116
main :: IO ()                                                             -- 117
main = ((case (evalExp fat' emptyEnv) of                                  -- 118
                         ValInt i -> print i                              -- 119
                         ValFunc _ -> print "function"                    -- 120
                         ValError err -> print ("error: " ++ err)))       -- 121
                                                                          -- 122