práce na parseru pro HM

[fp.git] / src / HM.hs

diff --git a/src/HM.hs b/src/HM.hs
index 83bbe04..065ccbb 100644 (file)
--- a/src/HM.hs
+++ b/src/HM.hs
@@ -11,18 +11,27 @@
 module HM
   ( -- * Types
     Type(..)
 module HM
   ( -- * Types
     Type(..)

-  , Term
+  , TypeScheme(..)
+  , Term(..)
+  , TypedTerm(..)

     -- * Type inference
   , algW
   ) where
 
     -- * Type inference
   , algW
   ) where
 

+import Control.Monad.State
+

 import HM.Term
 import HM.Parser
 
 type Substitution = TypeScheme -> TypeScheme
 import HM.Term
 import HM.Parser
 
 type Substitution = TypeScheme -> TypeScheme

+type VarS a = State Int a

 
 fresh :: TypeVarName
 fresh = undefined
 
 fresh :: TypeVarName
 fresh = undefined

+--fresh = do
+--  n <- get
+--  "a" ++ show n
+  

 
 substitute :: TypeScheme -> TypeVarName -> TypeScheme -> TypeScheme
 substitute = undefined
 
 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
 
 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