pastebin - collaborative debugging

import qualified Data.Map as Map
import Data.Maybe

data Type = UnitType
          | TypeVar String
          | ArrowType Type Type

-- Pretty print types

instance Show Type where
    show UnitType  = "Unit"
    show (TypeVar x) = x
    show (ArrowType t1 t2) = "(" ++ (show t1) ++ " -> " ++ (show t2) ++ ")"

-- Expressions

data Expr = Unit
          | Var String
          | App Expr Expr
          | Fun String Expr

type TypeAssign = (String, Type)

type TypeEnv = Map.Map String Type

-- pretty print values

instance Show Expr where
    show Unit = "unit"
    show (Var x) = x
    show (App e1 e2) = "(" ++ (show e1) ++ " " ++ (show e2) ++ ")"
    show (Fun x e) = "(fun " ++ x ++ " = " ++ (show e) ++ ")"

-- | Functions to generate fresh type-variables:

genNames name = map (\x -> name ++ (show x)) naturals
    where naturals = iterate (+ 1) 1

genTypeVars = map TypeVar . genNames

-- | The result type
data Constraint = Eq Type Type

-- Make it print'able
instance Show Constraint where
    show (Eq t1 t2) = (show t1) ++ "=" ++ (show t2)

-- |  The algorithm to infer types.
infer:: TypeEnv      -- ^ the environment
     -> Expr         -- ^ the expression whose type we want to infer
     -> Type         -- ^ the type of the expression
     -> [Type]       -- ^ the generator of fresh type-variables
     -> [Constraint] -- ^ a set of constraints

infer _ Unit t vars = [Eq t UnitType]

infer type_env (Var x) t vars = [(Eq ret_type t)]
    where ret_type = fromJust (Map.lookup x type_env)

infer type_env (App m n) t (a:vars) = e1_result ++ e2_result
    where
      e2_result = infer type_env n a vars
      e1_result = infer type_env m (ArrowType a t) new_vars
      new_vars = genTypeVars new_name
      new_name = (show a) ++ "_"

infer type_env (Fun x m) t (a:b:vars) = (Eq t (ArrowType a b)):exp_result
    where exp_result = infer (Map.insert x a type_env) m b vars

-- | Generates the constraints for certain type
inferTypes :: TypeEnv -> Expr -> [Constraint]
inferTypes type_env exp = infer type_env exp a vars
    where
      a = head (genTypeVars "a")
      vars = tail (genTypeVars "a")