UNB/ CS/ David Bremner/ teaching/ cs3613/ lectures/ examples/ haskell/ tfae.hs
type Symbol = String

data FAE =
  Number Integer|
  Boolean Bool|
  Add FAE FAE|
  Sub FAE FAE|
  Id Symbol|
  Fun { funParam::Symbol, argType:: TE, funBody::FAE }|
  App { funExp::FAE, argExp::FAE}|
  If { testExp::FAE, thenExp::FAE, elseExp::FAE }
  deriving (Show, Eq)

data TE =
  NumTE | BoolTE | ArrowTE {arg :: TE, result :: TE}
                   deriving (Show,Eq)

data Type =
  NumT | BoolT |  ArrowT {argT :: Type, resultT :: Type}
                  deriving (Show,Eq)
data TypeBind =
  Bind  { bName :: Symbol, bType :: Type }

type TypeEnv = [TypeBind]


get_type name [] = error "free variable, no type"
get_type name (x:xs) | name == (bName x) = (bType x)
                     | otherwise = get_type name xs


parse_type NumTE = NumT
parse_type BoolTE = BoolT
parse_type (ArrowTE l r) = ArrowT (parse_type l) (parse_type r)

typecheck::FAE->TypeEnv->Type

typecheck (Number _) _ = NumT
typecheck (Boolean _) _ = BoolT
typecheck (Add l r) env =
  let
    ltype = typecheck l env
    rtype = typecheck r env
  in
   if ltype == NumT && rtype == NumT then NumT else error "num num!"

typecheck (Id name) env = get_type name env

typecheck (Fun name te body) env =
  let
    arg_type = parse_type te
  in
   ArrowT arg_type (typecheck body  $ Bind name arg_type : env)

typecheck (App fn arg) env =
  let
    fntype = typecheck fn env
    argtype = typecheck arg env
  in
   case fntype of
     ArrowT fnarg_type result_type |argtype==fnarg_type -> result_type
                                   |otherwise -> error "arg type mismatch"
     _ -> error "wth?"


result1 = typecheck (App (Fun "x" NumTE (Add (Id "x") (Number 12)))
                    (Add (Number 1) (Number 17)))
          []
--