[TPat and TExp defined, construction of the implemented, context building, error handling
martin.hofmann@uni-bamberg.de**20090408144734] move ./src/Syntax/Translator.hs ./src/UI/Context.hs
hunk ./src/Syntax/Antiunifier.hs 23
+import Syntax.Expressions
+import Syntax.Patterns
hunk ./src/Syntax/Expressions.hs 4
-import Language.Haskell.TH (Exp (VarE, ConE, LitE, ListE, TupE, InfixE, AppE, CondE))
+import Language.Haskell.TH --(Name, mkName, Lit)
+import Syntax.Patterns
hunk ./src/Syntax/Expressions.hs 7
+import Syntax.Types
hunk ./src/Syntax/Expressions.hs 9
+import Data.Maybe (catMaybes)
hunk ./src/Syntax/Expressions.hs 12
+import Logging
hunk ./src/Syntax/Expressions.hs 16
+data TExp 
+    = TVarE Name Type
+    | TConE Name Type
+    | TLitE Lit Type
+    | TAppE TExp TExp Type
+    | TInfixE (Maybe TExp) TExp (Maybe TExp) Type
+    | TTupE [TExp] Type
+    | TListE [TExp] Type
+    | TCondE TExp TExp TExp Type
+--    | TLamE [TPat] TExp Type
+    -- | LetE [Dec] Exp
+    -- | CaseE Exp [Match]
+    -- | DoE [Stmt]
+    -- | CompE [Stmt]
+    -- | ArithSeqE Range
+    -- | SigE Exp Type
+    -- | RecConE Name [FieldExp]
+    -- | RecUpdE Exp [FieldExp]
+    deriving(Show)
+    
+instance Pretty TExp where
+    pretty (TVarE n t) = pretty (VarE n) <+> colon <> colon <+> pretty t
+    pretty (TConE n t) = pretty (ConE n) <+> colon <> colon <+> pretty t
+    pretty (TLitE l t) = pretty (LitE l) <+> colon <> colon <+> pretty t
+    pretty (TAppE e1 e2 t) =  pretty e1 <+> pretty e2  <+> colon <> colon <+> pretty t
+    pretty (TInfixE p1 n p2 t) = hsep (catMaybes [liftM pretty p1, Just (pretty n), liftM pretty p2]) <> colon <+> pretty t
+    pretty (TTupE es t) = (tupled (map pretty es)) <+> colon <> colon <+> pretty t
+    pretty (TListE l t) = (list (map pretty l)) <+> colon <> colon <+> pretty t
+--    pretty (TCondE TExp TExp TExp t
+
+instance TypeTag TExp where
+    typeOf (TVarE _ t) = t
+    typeOf (TConE _ t) = t
+    typeOf (TLitE _ t) = t
+    typeOf (TAppE _ _ t) = t
+    typeOf (TInfixE _ _ _ t) = t
+    typeOf (TTupE _  t) = t
+    typeOf (TListE _  t) = t
+    typeOf (TCondE _ _ _  t) = t
+
hunk ./src/Syntax/Expressions.hs 212
+
hunk ./src/Syntax/Patterns.hs 4
-import Language.Haskell.TH (Pat (VarP, ConP, LitP, ListP, TupP, InfixP))
+import Language.Haskell.TH 
hunk ./src/Syntax/Patterns.hs 6
-
+import Syntax.Types
hunk ./src/Syntax/Patterns.hs 8
+import Control.Monad
+import Data.Maybe (catMaybes)
+import Logging
+
+data TPat = TLitP Lit Type
+          | TVarP Name Type
+          | TTupP [TPat] Type
+          | TConP Name [TPat] Type
+          | TInfixP TPat Name TPat Type
+          | TListP [TPat] Type
+--          | TildeP Pat            -- no bang patterns
+--          | AsP Name Pat          -- no as-patterns
+--          | WildP                 -- no wildcards
+--          | RecP Name [FieldPat]  -- no records
+--          | SigP Pat Type         -- already made explicit
+        deriving (Show)
hunk ./src/Syntax/Patterns.hs 25
+instance Pretty TPat where
+    pretty (TLitP l t) = pretty (LitP l) <+> colon <> colon <+> pretty t
+    pretty (TVarP n t) = pretty (VarP n) <+> colon <> colon <+> pretty t
+    pretty (TTupP ps t) = tupled (map pretty ps) <+> colon <> colon <+> pretty t
+    pretty (TConP n ps t) = pretty (ConP n []) <> hcat (map pretty ps)  <+> colon <> colon <+> pretty t
+    pretty (TInfixP p1 n p2 t) = hcat [pretty p1, pretty n,pretty p2] <> colon <+> pretty t 
+    pretty (TListP ps t) = list (map pretty ps)  <+> colon <> colon <+> pretty t
+    
hunk ./src/Syntax/Substitution.hs 5
-import Syntax.Unifier
hunk ./src/Syntax/Substitution.hs 16
-insertApply :: (Eq a) =>  (Replacement a) -> (Substitution a) -> (Substitution a)
+nullSubst :: Substitution t
+nullSubst = []
+ 
+insertApply :: (Eq a, Term a) =>  (Replacement a) -> (Substitution a) -> (Substitution a)
hunk ./src/Syntax/Substitution.hs 29
-infixr 4 @@
-(@@) :: (Substitution a) -> (Substitution a) -> (Substitution a)
-s1 @@ s2 = [(u, apply s1 t) | (u,t) <- s2 ] ++ s1
+--infixr 4 @@
+--(@@) :: (Substitution a) -> (Substitution a) -> (Substitution a)
+--s1 @@ s2 = [(u, apply s1 t) | (u,t) <- s2 ] ++ s1
hunk ./src/Syntax/Terms.hs 9
-    Hole,
+    Hole(..),
hunk ./src/Syntax/Terms.hs 15
+    subtermAt, getVars, subtermOf, sameSymAt, getVarPos, hasVars,
hunk ./src/Syntax/Terms.hs 17
-    module Language.Haskell.TH
+   -- module Language.Haskell.TH,
hunk ./src/Syntax/Terms.hs 129
-
---    -- | @t1 `equals` t2 = true` if 't1' is identical to 't2' apart from
---    --   variable renaming
---    equal          :: t -> t -> Bool
---    
---    equalLs :: [t] -> [t] -> Bool
---    equalLs [][] = True
---    equalLs [] _ = False
---    equalLs _ [] = False
---    equalLs (t1:t1s)(t2:t2s) = (t1 `equal` t2) && (t1s `equalLs` t2s)
-    
-    
+   
hunk ./src/Syntax/Terms.hs 134
-    subtermOf       :: t
-                    -> t
-                    -> Bool
-    subtermOf t s = not $ null $ (getPos t s)
-    -- | returns subterm @s@ at position @p@ in term @t@, and 'Nothing' if there
-    --   is either no such position in this term, or no term at this position
-    --   (e.g. the term is a section of an infix operator)    
-    subtermAt         :: t                 -- ^ the term @t@
-                    -> Position            -- ^ a position @p@
-                    -> Maybe t             -- ^ subterm @s@ in @t@ at position @p@
-    subtermAt t Root = return t
-    subtermAt t pos = 
-        case pos of
-            (P i)     -> do { let subs = subterms t
-                            ; r <-  subs !?! i 
-                            ; noHole "Terms.subterm: No subterm at position" r}
-            (Dot p i ) -> do { let subs = subterms t
-                            ; sub <- subs !?! i
-                            ; r <- subtermAt sub p
-                            ; noHole "Terms.subterm: No subterm at position" r}
-    
+                    
hunk ./src/Syntax/Terms.hs 138
-    
-    -- | Returns 'True' if both terms have the same constructor symbol at 
-    --   'Position' @p@ or both have a variable. 'false' otherwise.
-    sameSymAt :: Position -> t -> t ->Bool
-    sameSymAt p t1 t2 = fromMaybe False $ liftM2 sameSymAtRoot (subtermAt t1 p)(subtermAt t2 p)
-    
-    subtermsNoHole :: t -> [t]
-    subtermsNoHole t = filter (== hole) (subterms t)
hunk ./src/Syntax/Terms.hs 150
-    -- |Returns a (unique) list of all variables in t
-    getVars         :: t -> [t]
-    getVars         = S.elems.getVars_ S.empty
-    
-    -- < Returns 'True' if the term 't' contains variables
-    hasVars         :: t -> Bool
-    hasVars = not.null.getVars
-    
-    -- |Returns a list of all variable position in t
-    getVarPos       :: t -> [(t,[Position])]
-    getVarPos t     =  [(st,getPos t st) | st <- (getVars t)]
-    
hunk ./src/Syntax/Terms.hs 154
-    
-    ctorAtPos :: t -> Position -> Bool
-    ctorAtPos t p = not $ varAtPos t p
hunk ./src/Syntax/Terms.hs 160
-    hole            :: t
-    noHole          :: String
-                    -> t
-                    -> Maybe t
-    noHole s t = if t == hole then fail s else return t
+    hole            :: (Term t) => t
+    
+subtermOf       :: (Term t) => t -> t -> Bool
+subtermOf t s = not $ null $ (getPos t s)
+-- | returns subterm @s@ at position @p@ in term @t@, and 'Nothing' if there
+--   is either no such position in this term, or no term at this position
+--   (e.g. the term is a section of an infix operator)    
+subtermAt         :: (Term t) => t                 -- ^ the term @t@
+                -> Position            -- ^ a position @p@
+                -> Maybe t             -- ^ subterm @s@ in @t@ at position @p@
+subtermAt t Root = return t
+subtermAt t pos = 
+    case pos of
+        (P i)     -> do { let subs = subterms t
+                        ; r <-  subs !?! i 
+                        ; noHole "Terms.subterm: No subterm at position" r}
+        (Dot p i ) -> do { let subs = subterms t
+                        ; sub <- subs !?! i
+                        ; r <- subtermAt sub p
+                        ; noHole "Terms.subterm: No subterm at position" r}
+
+
+-- | Returns 'True' if both terms have the same constructor symbol at 
+--   'Position' @p@ or both have a variable. 'false' otherwise.
+sameSymAt :: (Term t) => Position -> t -> t ->Bool
+sameSymAt p t1 t2 = fromMaybe False $ liftM2 sameSymAtRoot (subtermAt t1 p)(subtermAt t2 p)
+
+subtermsNoHole :: (Term t) => t -> [t]
+subtermsNoHole t = filter (== hole) (subterms t)
+
+-- |Returns a (unique) list of all variables in t
+getVars         :: (Term t) => t -> [t]
+getVars         = S.elems.getVars_ S.empty
+
+-- < Returns 'True' if the term 't' contains variables
+hasVars         :: (Term t) => t -> Bool
+hasVars = not.null.getVars
+
+-- |Returns a list of all variable position in t
+getVarPos       :: (Term t) => t -> [(t,[Position])]
+getVarPos t     =  [(st,getPos t st) | st <- (getVars t)]
+
+ctorAtPos :: (Term t) => t -> Position -> Bool
+ctorAtPos t p = not $ varAtPos t p
+    
+noHole          :: (Term t) => String
+                -> t
+                -> Maybe t
+noHole s t = if t == hole then fail s else return t
hunk ./src/Syntax/Types.hs 4
-import Language.Haskell.TH (Type(..))
+import Language.Haskell.TH --(Type(..), Cxt)
+import Syntax.Substitution
+import Control.Monad.State (MonadState, StateT, execStateT, put, get)
+import Data.List (union, nub)
+import Logging
+ 
hunk ./src/Syntax/Types.hs 11
-data TyTagged a = a ::: Type
+--data Type
+-- = ForallT [Name] Cxt Type
+-- | VarT Name
+-- | ConT Name
+-- | TupleT Int
+-- | ArrowT
+-- | ListT
+-- | AppT Type Type
+
+
+class TypeTag t where
+    typeOf :: t -> Type
+
+-- | splits an ArrowT in the type of a partial aplication and the type of 
+--   the argument
+splitArrowT :: Type -> (Type,Type)
+splitArrowT (AppT (AppT ArrowT a1) a2) = (a1,a2)
+
+reduceArrowT = fst . splitArrowT
+
+unArrowT :: Type -> [Type]
+unArrowT (AppT (AppT ArrowT e1) e2) = e1 : (unArrowT e2)
+unArrowT (ForallT ns cxt t) = map (addPredicates cxt) $ unArrowT t
+unArrowT e = [e]
+
+tyvars :: Type -> [Name]
+tyvars t@(VarT n) = [n]
+tyvars (AppT t1 t2) = (tyvars t1) `union` (tyvars t2)
+tyvars _   = [] -- VarT, ConT, TupltT, ArrowT,ListT
+
+addPredicates :: Cxt -> Type -> Type
+addPredicates cxt t = 
+    case tyvars t of
+        [] -> t
+        vs -> ForallT vs (filter (isIn vs) cxt) t
+    where 
+    isIn vs (AppT _ (VarT n)) = n `elem` vs
+
+unfoldAppTargs = tail . unfoldAppT
+
+fixType :: Type -> Type
+fixType (ForallT ns cxt t) 
+    | null cxt  = t
+    | null ns   = addPredicates cxt t
+    | otherwise = (ForallT (nub ns) cxt t) 
+fixType t = t
+
+unfoldAppT :: Type -> [Type]
+unfoldAppT e = f [] e
+    where 
+    f done e =
+        case e of
+            (ForallT ns cxt t) -> map (addPredicates cxt) $ f done t
+            (AppT e1 e2)       -> f (e2:done) e1
+            _owise             -> e:done
hunk ./src/Syntax/Types.hs 68
-class Tagged a where
-    tytag :: a -> TyTagged a
-    
-    
hunk ./src/Syntax/Unifier.hs 6
-    Unifieable(mgu, applyMgu, apply, matches, matchesLs, equal, equalLs, subsumes, subsumesLs)
+    Unifieable(mgu, applyMgu, matchesLs),
+    matches, equal, equalLs, subsumes, subsumesLs
hunk ./src/Syntax/Unifier.hs 16
-import Syntax.Terms (unfoldAppE, subtermOf, Term)
+import Syntax.Terms (subtermOf, Term)
+import Syntax.Expressions (unfoldAppE)
+import Syntax.Patterns
hunk ./src/Syntax/Unifier.hs 40
-    applyMgu :: (Substitution t) -> t -> LM t
+    
+    unify ::  t -> t -> U t
+    
+    applyMgu :: (Substitution t) -> t -> LM t    
+    
+    -- | The matching algorithm. Note, that different from unify, where
+    --   'unify t1 t2 == unify t2 t1', 'match t1 t2 == match t2 t1' iff 
+    --   't1 == t2'
+    match ::  t -> t -> U t
hunk ./src/Syntax/Unifier.hs 50
-    apply = unLM . applyMgu        
hunk ./src/Syntax/Unifier.hs 53
-    matchesWithSubs ::  t -> t -> LM (Substitution t)  
+    matchesWithSubs :: t -> t -> LM (Substitution t)  
hunk ./src/Syntax/Unifier.hs 55
-
+    
hunk ./src/Syntax/Unifier.hs 57
-    equal :: t -> t -> Bool
+    equal :: (Unifieable t) => t -> t -> Bool
hunk ./src/Syntax/Unifier.hs 60
-    -- | returns True if both lists are of the same length and the elements are 
-    --   pairwise 'equal'
-    equalLs :: [t] -> [t] -> Bool
-    equalLs l1 l2 = (matchesLs l1 l2) && (matchesLs l2 l1)
-    
-     
-    -- | Returns True if 'matchesWithSubs' does not 'fail', False if it does.
-    matches ::  t -> t -> Bool
-    matches t1 t2 = unLM $ do{matchesWithSubs t1 t2 >> return True} 
-                             `catchError` (const.return $ False)
hunk ./src/Syntax/Unifier.hs 64
-                             
-    -- | subsumes = flip matches
-    subsumes ::  t -> t -> Bool
-    subsumes = flip matches
-    
-    -- | subsumesLs = flip matchesLs
-    subsumesLs ::  [t] -> [t] -> Bool
-    subsumesLs = flip matchesLs
-    
-    -- | The matching algorithm. Note, that different from unify, where
-    --   'unify t1 t2 == unify t2 t1', 'match t1 t2 == match t2 t1' iff 
-    --   't1 == t2'
-    match ::  t -> t -> U t
-        
-    matchVar :: t -> t -> U t
-    matchVar var t = 
-        do unifier <- get  
-           case (lookup var unifier) of
-            Just val -> 
-                llogDE ( text "Found (Var <~ Val) in current unifier:" <^>
-                		 pretty var <+> text " <~ " <+> pretty val <$>
-                		 text "but need to match:" <^>
-                		 pretty var <+> text " <~ " <+> pretty t
-					   )
-				>> flush "No Match!"
-            Nothing  -> put (insert (var <~ t) unifier)
-    
-    unify ::  t -> t -> U t
-             
-    unifyVar :: t -> t -> U t
-    unifyVar var x = 
-        do unifier <- get  
-           lift $ setCurrentLogger "Terms.Unifier.unifyVar"
-           llogEnterDE
-           llogDE ( text "Var is:" <^> (pretty var) <$>
-					text "X is:" <^> (pretty x) <$>
-					text "Current unifier is:" <^> pretty unifier
-				  ) 
-           case (lookup var unifier) of
-            Just val -> 
-                llogDE ( text "Found (Var <~ Val) in current unifier:" <$>
-                		 indent 2 (pretty var) <+> text " <~ " <+> pretty val <$>
-                		 indent 2 (text "continue unify val x")
-                		) >>
-                unify val x
-            Nothing  -> do case (lookup x unifier) of
-                             Just val -> 
-                                llogDE ( text "Found (X <~ Val) in current unifier:" <^>
-                                		 (pretty x) <+> text "<~" <+> pretty val <^>
-                                		 text "continue unify var val"
-                                        ) >>
-                                unify var val
-                             Nothing  -> if var `subtermOf` x
-                                            then flush "Not unifieable"
-                                            else do llogDE ( text "Apply (Var <~ X) to current Unifier and Insert:" <^>
-                                            				 pretty var <+> text "<~" <+> pretty x
-                                            			   ) 
-                                                    put (insertApply (var <~ x) unifier)
+
+            
+
+
+
+-- | returns True if both lists are of the same length and the elements are 
+--   pairwise 'equal'
+equalLs :: (Unifieable t) => [t] -> [t] -> Bool
+equalLs l1 l2 = (matchesLs l1 l2) && (matchesLs l2 l1)
+
+ 
+-- | Returns True if 'matchesWithSubs' does not 'fail', False if it does.
+matches ::  (Unifieable t) => t -> t -> Bool
+matches t1 t2 = unLM $ do{matchesWithSubs t1 t2 >> return True} 
+                         `catchError` (const.return $ False)
+
+                         
+-- | subsumes = flip matches
+subsumes :: (Unifieable t) =>  t -> t -> Bool
+subsumes = flip matches
+
+-- | subsumesLs = flip matchesLs
+subsumesLs ::  (Unifieable t) => [t] -> [t] -> Bool
+subsumesLs = flip matchesLs
hunk ./src/Syntax/Unifier.hs 89
+matchVar :: (Unifieable t) => t -> t -> U t
+matchVar var t = 
+    do unifier <- get  
+       case (lookup var unifier) of
+        Just val -> 
+            llogDE ( text "Found (Var <~ Val) in current unifier:" <^>
+            		 pretty var <+> text " <~ " <+> pretty val <$>
+            		 text "but need to match:" <^>
+            		 pretty var <+> text " <~ " <+> pretty t
+				   )
+			>> flush "No Match!"
+        Nothing  -> put (insert (var <~ t) unifier)    
+         
+unifyVar :: (Unifieable t) => t -> t -> U t
+unifyVar var x = 
+    do unifier <- get  
+       lift $ setCurrentLogger "Terms.Unifier.unifyVar"
+       llogEnterDE
+       llogDE ( text "Var is:" <^> (pretty var) <$>
+				text "X is:" <^> (pretty x) <$>
+				text "Current unifier is:" <^> pretty unifier
+			  ) 
+       case (lookup var unifier) of
+        Just val -> 
+            llogDE ( text "Found (Var <~ Val) in current unifier:" <$>
+            		 indent 2 (pretty var) <+> text " <~ " <+> pretty val <$>
+            		 indent 2 (text "continue unify val x")
+            		) >>
+            unify val x
+        Nothing  -> do case (lookup x unifier) of
+                         Just val -> 
+                            llogDE ( text "Found (X <~ Val) in current unifier:" <^>
+                            		 (pretty x) <+> text "<~" <+> pretty val <^>
+                            		 text "continue unify var val"
+                                    ) >>
+                            unify var val
+                         Nothing  -> if var `subtermOf` x
+                                        then flush "Not unifieable"
+                                        else do llogDE ( text "Apply (Var <~ X) to current Unifier and Insert:" <^>
+                                        				 pretty var <+> text "<~" <+> pretty x
+                                        			   ) 
+                                                put (insertApply (var <~ x) unifier)
+
hunk ./src/Terms.hs 5
-    module Syntax.Antiunifier
+    module Syntax.Antiunifier,
+    module Syntax.Patterns,
+    module Syntax.Expressions
hunk ./src/Terms.hs 16
-                           , Exp (VarE, ConE, LitE, ListE, TupE, InfixE, AppE, CondE)
-                           , Pat (VarP, ConP, LitP, ListP, TupP, InfixP)
+                        --   , Exp (VarE, ConE, LitE, ListE, TupE, InfixE, AppE, CondE)
+                        --   , Pat (VarP, ConP, LitP, ListP, TupP, InfixP)
hunk ./src/Terms.hs 22
+import Syntax.Expressions
+import Syntax.Patterns
hunk ./src/UI/Context.hs 1
-
-module Syntax.Translator where
+{-# OPTIONS_GHC -fglasgow-exts -XTemplateHaskell #-}
+module UI.Context where
hunk ./src/UI/Context.hs 9
---import Language.Haskell.Exts.Pretty
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax
hunk ./src/UI/Context.hs 11
+import Data.List (partition)
hunk ./src/UI/Context.hs 13
-import Control.Monad (foldM)
-import Syntax.Terms -- for Ord Type
+import Control.Monad.State
+
+--import Syntax.Terms -- for Ord Type
+import Syntax.Expressions
+import Syntax.Patterns
+import Syntax.Types
hunk ./src/UI/Context.hs 22
-parseContext :: String ->  IO Context
-parseContext s = do 
-    (ParseOk mdule) <- parseFile s
-    foldM buildCtx emptyCtx $ moduleDecls  mdule 
+-------------------------------------------------------------------------------
+-- Building Context
+--------------------------------------------------------------------------------
+
+parseContext :: Context -> String ->  IO Context
+parseContext ctx s = do 
+    mdule <- parse s
+    foldM buildCtx ctx  (funBindsLast mdule) 
+    where
+    funBindsLast = uncurry (++) . (partition noFunBind) . moduleDecls
+    noFunBind (Hs.FunBind _ ) = False
+    noFunBind _               = True
+    parse s = do rs <- parseFile s
+                 case rs of 
+                    (ParseOk r) -> return r
+                    (ParseFailed sloc msg) -> 
+                        fail $ "Parsing failed at " ++ (show sloc) ++ " with message: " ++ msg  
+
hunk ./src/UI/Context.hs 46
-buildCtx ctx (Hs.DataDecl _ _ assts tname args condecls derive) =
+buildCtx ctx (Hs.DataDecl _ _ assts tname args condecls derive) = do
hunk ./src/UI/Context.hs 51
-        ctorNameTy cd  = case cd of 
-            (Hs.QualConDecl _ _ _ (Hs.ConDecl n tys)) -> ( T.toName n, ctorty $ map unBang tys);
-             _owise -> error $ "No records supported!"
+        ctorNameTy cd = case cd of 
+            (Hs.QualConDecl _ _ _ (Hs.ConDecl n tys)) ->  return ( T.toName n, ctorty $ map unBang tys);
+             _owise -> fail $ "No records supported!"
hunk ./src/UI/Context.hs 55
-        pNameTy = map ctorNameTy condecls
+    pNameTy <- mapM ctorNameTy condecls
hunk ./src/UI/Context.hs 57
-        pTysClass = map (\(n,_) ->  ((mkForallT assts (T.toType dataty)), (T.toName n))) derive
+    let pTysClass = map (\(n,_) ->  ((mkForallT assts (T.toType dataty)), (T.toName n))) derive
hunk ./src/UI/Context.hs 59
-    in return $ (addToConstructors pNameTy) . (addToInstances pTysClass) $ ctx
-buildCtx ctx (Hs.ClassDecl sloc assts cname anames _ decls) =  
-    let sigds        = concatMap toDec $ filter isTypeDecl $ map getClsDecl decls
-        -- extract type signatures 'SigD's from '[ClassDecl]'
-        getClsDecl d = case d of 
-                        (Hs.ClsDecl dcl) -> dcl ;
-                        _owise -> error $ "Only plain vanilla class declarations are supported! " ++ (show sloc)
+    return $ (addToConstructors pNameTy) . (addToInstances pTysClass) $ ctx
+buildCtx ctx (Hs.ClassDecl sloc assts cname anames _ decls) = do
+    let getClsDecl d = case d of 
+                        (Hs.ClsDecl dcl) -> return dcl ;
+                        _owise -> fail $ "Only plain vanilla class declarations are supported! " ++ (show sloc)
hunk ./src/UI/Context.hs 65
+    clsdecls <- mapM getClsDecl decls 
+    let sigds        = concatMap toDec $ filter isTypeDecl $ clsdecls
+        -- extract type signatures 'SigD's from '[ClassDecl]'
hunk ./src/UI/Context.hs 77
-    in return $ (addToTypes pNameTy ) . (addToMembers pClssFuns) . (addToClasses pClssSupr) $ ctx 
+    return $ (addToTypes pNameTy ) . (addToMembers pClssFuns) . (addToClasses pClssSupr) $ ctx 
hunk ./src/UI/Context.hs 86
-        ts    -> error $ "Multi parameter type classes are not supported at: " ++ (show sloc)   
+        ts    -> fail $ "Multi parameter type classes are not supported at: " ++ (show sloc)   
hunk ./src/UI/Context.hs 89
-    let pNmsTys  = map (\(SigD n t) -> (n,t)) $ toDec d  
+    let pNmsTys  = map (\(SigD n t) -> (n,fixType t)) $ toDec d  
hunk ./src/UI/Context.hs 92
-buildCtx ctx d@(Hs.FunBind _ ) = 
+buildCtx ctx d@(Hs.FunBind _ ) = do 
hunk ./src/UI/Context.hs 94
-    in  return $ addToBindings [(n,cls)] ctx
+    case clauses2rules ctx n cls of
+        Right rs -> return $ addToBindings [rs] ctx
+        Left msg -> fail $ msg
hunk ./src/UI/Context.hs 99
-    putStrLn $ "...Skipping GDataDecl at " ++ (show sloc)
+    putStrLn $ "...Skipping GDataDecl at Defining" ++ (show sloc)
hunk ./src/UI/Context.hs 185
-mkForallT :: (T.ToType a) => [a] -> Type -> Type
-mkForallT assts ty   = ForallT [] (map T.toType assts) ty             
+mkForallT :: [Hs.Asst] -> Type -> Type
+mkForallT assts ty   = 
+    fixType $ ForallT (concatMap getVName assts) (map T.toType assts) ty
+    where
+    getVName (Hs.ClassA _ tys) = map (\(Hs.TyVar n) -> T.toName n) tys             
+
hunk ./src/UI/Context.hs 192
--- Context
+-- Using Context
+--------------------------------------------------------------------------------
+
+type C a = StateT Context (Either String) a
+
+getVarType :: Name -> C Type
+getVarType n = do
+    m <- gets ctx_types
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Variable not in context: " ++ (show n)
+--    return $ fromMaybe (fail $ "variable not in context " ++ (show n)) $  
+
+getConType n = do
+    m <- gets ctx_ctors 
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Ctor not in context: " ++ (show n)
+        
+class ToTExp t where
+    toTExp :: Type -> t -> C TExp
+class ToTPat t where
+    toTPat :: Type -> t -> C TPat
+        
+
+instance ToTExp Exp where
+    toTExp t (VarE n)          = return $ TVarE n t
+    toTExp t (LitE l)          = return $ TLitE l t
+    toTExp t (ConE n)          = return $ TConE n t
+    toTExp lstty (ListE l)     = do
+        let [elemty] = unfoldAppTargs lstty
+        tes <- mapM (toTExp elemty) l
+        return $ TListE  tes lstty
+    toTExp tupty (TupE l)      = do
+        let tuptys = unfoldAppTargs tupty
+        tes <- zipWithM toTExp tuptys l 
+        return $ TTupE tes tupty
+    toTExp t e@(AppE _ _ ) =
+        case unfoldAppE e of
+            ((VarE n):args) -> do
+                ty <- getVarType n >>= specialise t
+                tyargs <- return $ unArrowT ty
+                teargs <- zipWithM toTExp tyargs args
+                tVarE <- toTExp ty (VarE n)
+                return $ foldTAppE tVarE teargs     
+            ((ConE n):args) -> do
+                ty <- getConType n >>= specialise t
+                tyargs <- return $ unArrowT ty
+                teargs <- zipWithM toTExp tyargs args
+                tConE <- toTExp ty (ConE n)
+                return $ foldTAppE tConE teargs                 
+    toTExp t (InfixE mba1 (ConE n) mba2) = do
+                ty <- getConType n >>= specialise t
+                (tya1:tya2:_) <- return $ unArrowT ty
+                a1' <- case mba1 of 
+                        (Just a1) -> liftM Just $ toTExp tya1 a1
+                        _owise    -> return Nothing
+                a2' <- case mba2 of 
+                        (Just a2) -> liftM Just $ toTExp tya2 a2
+                        _owise    -> return Nothing
+                tConE <- toTExp ty (ConE n)
+                return $ TInfixE a1' tConE a2' t       
+    toTExp _ e = fail $ "No Translation defined for " ++ (show e)
+--    toTexp TCondE TExp TExp TExp Type
+--    toTexp TLamE [TPat] TExp Type
+
+instance ToTPat Pat where
+    toTPat t (LitP l) = return $ TLitP l t
+    toTPat t (VarP n) = return $ TVarP n t
+    toTPat tupty (TupP l) = do
+        let tuptys = unfoldAppTargs tupty
+        tes <- zipWithM toTPat tuptys l 
+        return $ TTupP tes tupty
+    toTPat t (ConP n args) = do
+        ty <- getConType n >>= specialise t
+        tyargs <- return $ unArrowT ty
+        teargs <- zipWithM toTPat tyargs args
+        return $ TConP n teargs t
+    toTPat lstty (ListP l) = do
+        let [elemty] = unfoldAppTargs lstty
+        tes <- mapM (toTPat elemty) l
+        return $ TListP  tes lstty                 
+    toTPat t (InfixP a1 n a2) = do
+                ty <- getConType n >>= specialise t
+                (tya1:tya2:_) <- return $ unArrowT ty
+                a1' <- toTPat tya1 a1
+                a2' <- toTPat tya2 a2
+                return $ TInfixP a1' n a2' t     
+    toTPat _ p = fail $ "No Translation defined for " ++ (show p)      
+--          | TInfixP TPat Name TPat
+
+specialise t a =  return a
+
+foldTAppE :: TExp -> [TExp] -> TExp
+foldTAppE e [] = e 
+foldTAppE et (e:es) = foldTAppE (TAppE et e (reduceArrowT . typeOf $ et)) es
+
+
+type Rule = ([TPat],TExp)
+type Rules = [Rule]
+
+clauses2rules :: Context -> Name -> [Clause] -> Either String (Name, [([TPat], TExp)])
+clauses2rules cxt n cls = 
+    case Map.lookup n (ctx_types cxt)of
+        (Just ty) -> do rs <- evalStateT (mapM (clause2rule ty) cls) cxt
+                        return (n,rs)
+        Nothing   -> fail $ "Not in Context: " ++ (show n)
+        
+    where
+    clause2rule ty (Clause ls (NormalB rs) _) = do
+        let argty = unArrowT ty
+        ls' <- zipWithM toTPat (init argty) ls
+        rs' <- toTExp (last argty) rs
+        return (ls', rs')
+-------------------------------------------------------------------------------
+-- Defining Context
hunk ./src/UI/Context.hs 312
-    { ctx_bindings :: Map.Map Name [Clause]
+    { ctx_bindings :: !(Map.Map Name Rules)
hunk ./src/UI/Context.hs 314
-    , ctx_types    :: Map.Map Name Type
+    , ctx_types    :: !(Map.Map Name Type)
hunk ./src/UI/Context.hs 316
-    , ctx_ctors    :: Map.Map Name Type
+    , ctx_ctors    :: !(Map.Map Name Type)
hunk ./src/UI/Context.hs 318
-    , ctx_classes  :: Map.Map Name [Name]
+    , ctx_classes  :: !(Map.Map Name [Name])
hunk ./src/UI/Context.hs 320
-    , ctx_members  :: Map.Map Name [Name]
+    , ctx_members  :: !(Map.Map Name [Name])
hunk ./src/UI/Context.hs 322
-    , ctx_instances  :: Map.Map Type [Name]
+    , ctx_instances  :: !(Map.Map Type [Name])
hunk ./src/UI/Context.hs 324
-    , ctx_typesyns  :: Map.Map  Type Type
-}--deriving(Show)
+    , ctx_typesyns  :: !(Map.Map  Type Type)
+}deriving(Show)
hunk ./src/UI/Context.hs 329
-addToBindings :: [(Name, [Clause])] -> Context -> Context
+addToBindings :: [(Name, Rules)] -> Context -> Context
hunk ./src/UI/Context.hs 344
-addToConstructors l c  = foldl add c l  
+addToConstructors l c  =  foldl add c l
hunk ./src/UI/Context.hs 347
-        let ctors = ctx_types ctx 
+        let ctors = ctx_ctors ctx 
hunk ./src/UI/Context.hs 379
-instance Show Context where
-    show ctx = "Context{" ++
-               "\n  Bindings: " ++ (show . pretty . ctx_bindings $ ctx) ++
-               "\n  Types   : " ++ (show . pretty . ctx_types $ ctx) ++
-               "\n  ClssFuns: " ++ (show . pretty . ctx_classes $ ctx) ++
-               "\n  ClssInsts: " ++ (show . pretty . ctx_instances $ ctx) ++
-               "\n  TypeSyns: " ++ (show . pretty . ctx_typesyns $ ctx) ++
-               "\n"
+
hunk ./src/UI/Context.hs 392
-defaultContext = emptyCtx
+defaultContext = Ctx 
+    { ctx_bindings  = defaultbindings
+    , ctx_types     = defaulttypes
+    , ctx_ctors     = defaultctors
+    , ctx_classes   = defaultclasses
+    , ctx_members   = defaultmembers
+    , ctx_instances = defaultinstances
+    , ctx_typesyns = defaulttypesyns
+}
hunk ./src/UI/Context.hs 402
+defaultbindings  = Map.empty
+defaulttypes     = Map.empty
+defaultctors     = Map.fromList 
+    [('(:), (AppT 
+             (AppT ArrowT (mkVarT "a")) 
+             (AppT (AppT ArrowT (AppT ListT (mkVarT "a"))) 
+                   (AppT ListT (mkVarT "a")))))
+    ,('[], (AppT ListT (mkVarT "a")) )
+    ]
+defaultclasses   = Map.fromList
+    [(mkName "Ord",[mkName "Eq"])]
+defaultmembers   = Map.empty
+defaultinstances = Map.empty
+defaulttypesyns  = Map.empty
hunk ./src/UI/Context.hs 417
+mkVarT = VarT . mkName
hunk ./src/UI/Context.hs 428
+
+--mergeCtx :: Context -> Context -> Context
+--mergeCtx c1 c2 = Ctx
+--    { ctx_bindings  = (Map.union `on` ctx_bindings) c1 c2
+--    , ctx_types     = (Map.union `on` ctx_types) c1 c2
+--    , ctx_ctors     = (Map.union `on` ctx_ctors) c1 c2
+--    , ctx_classes   = ((Map.unionWith (++)) `on` ctx_classes) c1 c2
+--    , ctx_members   = (Map.union `on` ctx_members) c1 c2
+--    , ctx_instances = ((Map.unionWith (++)) `on` ctx_instances) c1 c2
+--    , ctx_typesyns  = (Map.union `on` ctx_typesyns) c1 c2 
+--    }
+ 
hunk ./src/UI/REPLoop.hs 31
-                    putStrLn $ "\nInterrupted (" ++ show err ++ ")"
+                    putStrLn $ "\nInterrupted (" ++ (show err) ++ " )"
hunk ./src/UI/UIStarter.hs 13
-import Syntax.Translator
+import UI.Context
hunk ./src/UI/UIStarter.hs 42
-    , context :: Context
+    , context :: !Context
hunk ./src/UI/UIStarter.hs 48
-    { verbose   = False
+    { verbose   = True
hunk ./src/UI/UIStarter.hs 105
-    ctx <- parseContext path
-    return (False,s{context=ctx})
+    ctx <- parseContext (context s) path
+    return $ ctx `seq` (False,s{context=ctx})