X-Git-Url: http://git.tomasm.cz/fp.git/blobdiff_plain/64abbeaeddb1956b5c07a29cc6caea1a971101b5..880eb9d73e5ea9239698d8f6d294032b6e339310:/src/HM.hs

diff --git a/src/HM.hs b/src/HM.hs
index 83bbe04..065ccbb 100644
--- a/src/HM.hs
+++ b/src/HM.hs
@@ -11,18 +11,27 @@
 module HM
   ( -- * Types
     Type(..)
-  , Term
+  , TypeScheme(..)
+  , Term(..)
+  , TypedTerm(..)
     -- * Type inference
   , algW
   ) where
 
+import Control.Monad.State
+
 import HM.Term
 import HM.Parser
 
 type Substitution = TypeScheme -> TypeScheme
+type VarS a = State Int a
 
 fresh :: TypeVarName
 fresh = undefined
+--fresh = do
+--  n <- get
+--  "a" ++ show n
+  
 
 substitute :: TypeScheme -> TypeVarName -> TypeScheme -> TypeScheme
 substitute = undefined
@@ -32,17 +41,17 @@ unify (TScheme (Primitive a)) (TScheme (Primitive b)) | a == b = Right id
 unify (TScheme (TypeVar a)) (TScheme (TypeVar b)) | a == b = Right id
 unify a b = Left $ "cannot unify " ++ show a ++ " with " ++ show b
 
-algW :: HMTerm -> Either String TypeScheme
-algW (HMTerm (Var _) t) = Right t
-algW (HMTerm (Lambda x t) (TScheme p)) = do
-  let v = TScheme (TypeVar fresh)
-      np = substitute v x t
-  unify p np
-algW (HMTerm (App u v) t) = do
-  tu <- algW u
-  tv <- algW v
-  case tu of
-    (TScheme (TypeFunction a b)) -> do
-      unify a tv
-      return b
-    _ -> Left $ "cannot apply " ++ show tu ++ " to " ++ show tv
+algW :: TypedTerm -> Either String TypeScheme
+algW (TTerm (Var _) t) = Right t
+--algW (TTerm (Lam x t) (TScheme p)) = do
+--  let v = TScheme (TypeVar fresh)
+--      np = substitute v x t
+--  unify p np
+--algW (TTerm (App u v) t) = do
+--  tu <- algW u
+--  tv <- algW v
+--  case tu of
+--    (TScheme (TypeFunction a b)) -> do
+--      unify a tv
+--      return b
+--    _ -> Left $ "cannot apply " ++ show tu ++ " to " ++ show tv