[Implemeted specialising types when translating and added an type checker via IO to GHC API
martin.hofmann@uni-bamberg.de**20090414110857] hunk ./src/UI/Context.hs 11
-import Data.List (partition)
+import Data.List (partition, union)
hunk ./src/UI/Context.hs 15
---import Syntax.Terms -- for Ord Type
+import Syntax.Terms
hunk ./src/UI/Context.hs 19
-import Logging
+import Logging hiding (trace)
hunk ./src/UI/Context.hs 44
-    let pSynTy = map (\(TySynD n args t) ->  ((mkAppT n args), t) ) $ toDec d
+    let pSynTy = map (\(TySynD n args t) ->  ((mkAppT n args), fixType t) ) $ T.toDec d
hunk ./src/UI/Context.hs 70
-    let sigds        = concatMap toDec $ filter isTypeDecl $ clsdecls
+    let sigds        = concatMap T.toDec $ filter isTypeDecl $ clsdecls
hunk ./src/UI/Context.hs 94
-    let pNmsTys  = map (\(SigD n t) -> (n,fixType t)) $ toDec d  
+    let pNmsTys  = map (\(SigD n t) -> (n, t)) $ T.toDec d  
hunk ./src/UI/Context.hs 98
-    let [(FunD n cls)] = toDec d
+    let [(FunD n cls)] = T.toDec d
hunk ./src/UI/Context.hs 167
-toDec :: Hs.Decl -> [Dec]
-toDec (Hs.TypeSig _ ns t) =  [SigD (T.toName n) (T.toType t) | n <- ns]
-toDec decs                = [T.toDec decs] 
+--toDec :: Hs.Decl -> [Dec]
+--toDec (Hs.TypeSig _ ns t) =  [SigD (T.toName n) (T.toType t) | n <- ns]
+--toDec decs                = [T.toDec decs] 
hunk ./src/UI/Context.hs 209
+getConType :: Name -> C Type
hunk ./src/UI/Context.hs 215
+        
+getSubClasses :: Name -> C [Name]        
+getSubClasses n = do
+    m <- gets ctx_classes
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Class not in context: " ++ (show n)
+        
+getInstances :: Type -> C [Name]        
+getInstances n = do
+    m <- gets ctx_instances
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Type not in context: " ++ (show n)
+
hunk ./src/UI/Context.hs 269
-    toTExp t (InfixE mba1 (ConE n) mba2) = do
-                ty <- getConType n >>= specialise t
+    toTExp t (InfixE mba1 (ConE n) mba2) = do     
+                ty <- getConType n >>=  specialise t
hunk ./src/UI/Context.hs 291
-    toTPat t (ConP n args) = do
+    toTPat t (ConP n args) = do 
hunk ./src/UI/Context.hs 311
+--   so 't1' is always more general the 't2'
+specialise t1 t2 = do --return t1
+    subst <- instantiate (last . unArrowT $ t2) t1
+    return $ applySubs t2 subst
hunk ./src/UI/Context.hs 316
-specialise t1 t2 =  return t2
+applySubs :: Type -> ( Substitution Type) -> Type
+applySubs t@(VarT n) s = 
+    case lookup t s of
+       (Just t') -> t'
+       _owise    -> t
+applySubs t@(ForallT _ _ (VarT n)) s =  
+    case lookup (VarT n) s  of
+       (Just t') -> t'
+       _owise    -> t
+applySubs (ForallT ns ctx t) s = (ForallT ns ctx (applySubs t s))
+applySubs (AppT t1 t2) s =
+    AppT (applySubs t1 s) (applySubs t2 s)
+applySubs t _     =  t
+       
+instantiate :: Type -> Type -> C (Substitution Type)
+instantiate v@(VarT n) t  = return [v <~ t]
+instantiate (ForallT ns ctx t1) t2 = instantiate t1 t2    
+instantiate t1@(AppT a11 a12) t2@(AppT a21 a22) =
+    liftM2 union (instantiate a11 a21) (instantiate a12 a22)
+    --liftM concat $ mapM (uncurry instantiate) $ zip (unfoldAppT t1) (unfoldAppT t2)
+instantiate (ConT n1) (ConT n2) 
+    | n1 == n2            = return nullSubst
+    | otherwise           = fail "types do not unify1"
+instantiate (TupleT i1) (TupleT i2) 
+    | i1 == i2            = return nullSubst
+    | otherwise           = fail "types do not unify2"
+instantiate (TupleT i) (ConT n) 
+    | isTuple n i         = return nullSubst
+    | otherwise           = fail "types do not unify3"
+instantiate (ConT n)(TupleT i)  
+    | isTuple n i         = return nullSubst
+    | otherwise           = fail "types do not unify4"
+instantiate ArrowT ArrowT = return nullSubst
+instantiate ListT ListT   = return nullSubst
+instantiate ListT (ConT n)
+    | isNil n             = return nullSubst
+    | otherwise           = fail "types do not unify5"
+instantiate (ConT n) ListT 
+    | isNil n             = return nullSubst
+    | otherwise           = fail "types do not unify6"
+instantiate a b           = fail $ "types do not unify" ++ (show (a,b))
hunk ./src/UI/Context.hs 358
+ 
+--data Type
+-- = ForallT [Name] Cxt Type
+-- | VarT Name
+-- | ConT Name
+-- | TupleT Int
+-- | ArrowT
+-- | ListT
+-- | AppT Type Type
hunk ./src/UI/Context.hs 420
-addToTypes l c  = foldl add c l  
+addToTypes l c  = foldl add c l 
addfile ./src/UI/IOTypeCheck.hs
hunk ./src/UI/IOTypeCheck.hs 1
-
+
+module UI.IOTypeCheck where
+
+import GHC
+import GHC.Paths ( libdir )
+import DynFlags ( defaultDynFlags )
+import Control.Monad.Error
+ 
+typecheck f = do
+    ok <- typecheck_ f
+    case ok of
+        Succeeded -> return True
+        Failed    -> return False    
+
+-- TODO this is not nice. I would prfer to catch the error myself and not get a
+-- SuccessFlag 
+typecheck_ :: FilePath -> IO SuccessFlag
+typecheck_ p = (do
+   -- defaultErrorHandler defaultDynFlags $ do
+     runGhc (Just libdir) $ do
+        dflags <- getSessionDynFlags
+        setSessionDynFlags dflags
+        target <- guessTarget p Nothing
+        setTargets [target]
+        load LoadAllTargets)
hunk ./src/UI/UIStarter.hs 14
+import UI.IOTypeCheck
hunk ./src/UI/UIStarter.hs 105
-runCmd s (Load path) = do
-    ctx <- parseContext (context s) path
-    return $ ctx `seq` (False,s{context=ctx})
+runCmd s (Load path) = do 
+    ok <- typecheck path    
+    if ok 
+      then do ctx <- parseContext (context s) path
+              return $ ctx `seq` (False,s{context=ctx})
+      else return (False, s)   
+        
+    