Handle another lookup failure in typeMap
[darcs-mirror-sem_syn.git] / Type.hs
diff --git a/Type.hs b/Type.hs
index 35e615e..b3fa938 100644 (file)
--- a/Type.hs
+++ b/Type.hs
@@ -13,6 +13,26 @@ import Data.List (nub,nubBy,union)
 import Data.Map (Map)
 import qualified Data.Map as Map
 
+-- type erasure
+eraseType (AST decls) =
+    AST $ map (\(Decl f ftype ps e) ->
+             Decl f FTUndet (map eraseTypeP ps) (eraseTypeE e)) decls 
+
+eraseTypeP (PVar id t varname)   
+    = PVar id TUndet varname
+eraseTypeP (PCon id t conname ps)
+    = PCon id TUndet conname (map eraseTypeP ps)
+
+eraseTypeE (EVar id t varname) 
+    = EVar id TUndet varname 
+eraseTypeE (ECon id t conname es)
+    = ECon id TUndet conname (map eraseTypeE es)
+eraseTypeE (EFun id t funname es)
+    = EFun id TUndet funname (map eraseTypeE es)
+
+eraseTypeT (TAST decls) = 
+    TAST $ map (\(TDecl f ps es bs) -> 
+                    TDecl f (map eraseTypeP ps) (map eraseTypeE es)bs) decls
 
 -- type inference
 
@@ -26,16 +46,13 @@ initTMap =
 
 
 typeInference (AST decls) = 
-    let mAst = do { (decls',_,_) <- 
-                        foldr (\decls m -> 
-                                   do (rdecls, tMap,  icount)  <- m
-                                      (decls', tMap', icount') <- inferenceStep decls tMap icount
-                                      return $ (decls'++rdecls, tMap', icount')
-                              ) (return ([],initTMap,initIcount)) declss
-                  ; return $ AST decls' } 
-    in case mAst of 
-         Left s  -> error s 
-         Right a ->  a 
+    do { (decls',_,_) <- 
+             foldr (\decls m -> 
+                        do (rdecls, tMap,  icount)  <- m
+                           (decls', tMap', icount') <- inferenceStep decls tMap icount
+                           return $ (decls'++rdecls, tMap', icount')
+                   ) (return ([],initTMap,initIcount)) declss
+       ; return $ AST decls' } 
     where
       initIcount = 100 -- FIXME 
       declss = 
@@ -58,12 +75,9 @@ typeInference (AST decls) =
 
 
 inferenceStep decls tmap icount = 
-    let (decls0,  (tmpMap, icount0))  
-            = runState (makeInitConstr tmap decls) ([],icount)
-        (decls' , (constr, icount')) 
-            = runState (mapM (assignTypeVars tmpMap tmap) decls0) ([],icount0)
-    in
-      do { (tmpMap', etypeMap') <- solveConstr tmpMap constr
+      do { (decls0,  (tmpMap, icount0)) <- runStateT (makeInitConstr tmap decls) ([],icount)
+         ; (decls' , (constr, icount')) <- runStateT (mapM (assignTypeVars tmpMap tmap) decls0) ([],icount0)
+         ; (tmpMap', etypeMap') <- solveConstr tmpMap constr
          ; let decls'' = map (repl tmpMap' etypeMap') decls'
          ; return (decls'', tmpMap' ++ tmap, icount') }
         where 
@@ -192,7 +206,9 @@ assignTypeVars tmpMap typeMap (Decl fname ftype ps e) =
                      do { ps' <- mapM assignTypeVarsP ps 
                         ; unifyFT t' (TFun [] (map typeofP ps') (TVar i))
                         ; unifyT  t  (TVar i)
-                        ; return $ PCon id (TVar i) c ps' }}
+                        ; return $ PCon id (TVar i) c ps' }
+                 Nothing -> fail $ "No entry " ++ show c ++ " in type map"
+             }
       assignTypeVarsE (EVar id t v) = 
           do { i <- newTypeVar 
              ; unifyT t (TVar i)
@@ -204,7 +220,9 @@ assignTypeVars tmpMap typeMap (Decl fname ftype ps e) =
                      do { es' <- mapM assignTypeVarsE es 
                         ; unifyFT t' (TFun [] (map typeofE es') (TVar i))
                         ; unifyT  t  (TVar i)
-                        ; return $ ECon id (TVar i) c es' }}
+                        ; return $ ECon id (TVar i) c es' }
+                 Nothing -> fail $ "No entry " ++ show c ++ " in type map"
+             }
       assignTypeVarsE (EFun id t f es) =
           do { i <- newTypeVar
              ; case lookup f (typeMap ++ tmpMap)  of
@@ -214,7 +232,7 @@ assignTypeVars tmpMap typeMap (Decl fname ftype ps e) =
                         ; unifyT  t  (TVar i)
                         ; return $ EFun id (TVar i) f es' }
                  _ ->
-                     error $ (show f ++ " is not in " ++ show (typeMap ++ tmpMap))
+                     fail $ (show f ++ " is not in " ++ show (typeMap ++ tmpMap))
              }
 --      unifyT :: Type -> Type -> State ([(Type,Type)],Int) ()
       unifyT (TUndet) _ = return ()
@@ -243,4 +261,4 @@ assignTypeVars tmpMap typeMap (Decl fname ftype ps e) =
           TCon t (map (replaceTVar table) ts)
 
                      
-                          
\ No newline at end of file
+