[made an separate package for Context and ContextBuilder
martin.hofmann@uni-bamberg.de**20090416123824
 The motivation was primarily to break cyclic module dependencies when using the SynthesisContext (storing type and type class information) for matching and unification. This is relevant, when the polymorphic types for Igor are required. 
] adddir ./src/Context
move ./src/UI/Context.hs ./src/Context/ContextBuilder.hs
hunk ./src/Context/ContextBuilder.hs 2
-module UI.Context (
-    C, getVarType, getConType, getSubClasses, getInstances,
-    Context(..), emptyCtx, defaultContext,
-    parseContext, buildCtx, 
+module Context.ContextBuilder (
+    
+    parseContext, buildCtx,
+    
+    module Context.ModuleContext 
hunk ./src/Context/ContextBuilder.hs 23
---import Syntax.Unifier
hunk ./src/Context/ContextBuilder.hs 25
-import Language.Haskell.Meta.Parse
---import qualified Language.Haskell.Meta.Syntax.Translate as T
+--import Context.SynthesisContext
+import Context.ModuleContext
hunk ./src/Context/ContextBuilder.hs 28
+import Language.Haskell.Meta.Parse
hunk ./src/Context/ContextBuilder.hs 30
-import Data.Generics 
-import Language.Haskell.TH.Syntax
-import Language.Haskell.Exts.Parser hiding (parseModule)
+import Data.Generics
+import Language.Haskell.Exts.Parser (ParseResult(..))
hunk ./src/Context/ContextBuilder.hs 35
-type Rule = ([TPat],TExp)
-type Rules = [Rule]
hunk ./src/Context/ContextBuilder.hs 39
-parseContext :: Context -> String ->  IO Context
+
+
+parseContext :: ModuleCtx -> String ->  IO ModuleCtx
hunk ./src/Context/ContextBuilder.hs 57
-buildCtx :: Context -> Hs.Decl -> IO Context
+buildCtx :: ModuleCtx -> Hs.Decl -> IO ModuleCtx
hunk ./src/Context/ContextBuilder.hs 109
-    let pNmsTys  = map (\(SigD n t) -> (n, t)) $ toDec d  
+    let pNmsTys  = map (\(SigD n t) -> (n, fixType t)) $ toDec d  
hunk ./src/Context/ContextBuilder.hs 211
-
+-- +++++++++++++++++
+-- This should be rather imlemented with 'unify', however, I have not solved 
+-- unification of polymorphic types with type classes. Using 'unify' will also
+-- cause a module cycle at the moment. So this just instantiates variables 
+--  in the fsecond type, ignornig 'ForallT' 
hunk ./src/Context/ContextBuilder.hs 220
-specialise :: Type -> Type -> StateT Context (Either String) Type
+specialise :: Type -> Type -> StateT ModuleCtx (Either String) Type
hunk ./src/Context/ContextBuilder.hs 239
-instantiate :: Type -> Type -> StateT Context (Either String) [(Type,Type)]
+-- This is a quick-and-dirty-kind-of-unification function       
+instantiate :: Type -> Type -> StateT ModuleCtx (Either String) [(Type,Type)]
hunk ./src/Context/ContextBuilder.hs 248
-    | otherwise           = fail "types do not unify1"
+    | otherwise           = fail "types do not unify"
hunk ./src/Context/ContextBuilder.hs 251
-    | otherwise           = fail "types do not unify2"
+    | otherwise           = fail "types do not unify"
hunk ./src/Context/ContextBuilder.hs 254
-    | otherwise           = fail "types do not unify3"
+    | otherwise           = fail "types do not unify"
hunk ./src/Context/ContextBuilder.hs 257
-    | otherwise           = fail "types do not unify4"
+    | otherwise           = fail "types do not unify"
hunk ./src/Context/ContextBuilder.hs 262
-    | otherwise           = fail "types do not unify5"
+    | otherwise           = fail "types do not unify"
hunk ./src/Context/ContextBuilder.hs 265
-    | otherwise           = fail "types do not unify6"
+    | otherwise           = fail "types do not unify"
hunk ./src/Context/ContextBuilder.hs 267
+-- +++++++++++++++++
+       
hunk ./src/Context/ContextBuilder.hs 270
- 
+--------------------------------------------------------------------------------
+-- Translating 
+--------------------------------------------------------------------------------
hunk ./src/Context/ContextBuilder.hs 362
-clauses2rules :: Context -> Name -> [Clause] -> Either String (Name, [([TPat], TExp)])
+clauses2rules :: ModuleCtx -> Name -> [Clause] -> Either String (Name, [([TPat], TExp)])
hunk ./src/Context/ContextBuilder.hs 364
-    case Map.lookup n (ctx_types cxt)of
+    case Map.lookup n (mctx_types cxt)of
hunk ./src/Context/ContextBuilder.hs 377
+-- stolen from Language.Haskell.Meta.Syntax.Translate from package haskell.src.meta
hunk ./src/Context/ContextBuilder.hs 399
--- stolen from Language.Haskell.Meta.Syntax.Translate from package haskell.src.meta
hunk ./src/Context/ContextBuilder.hs 838
-        
-
--------------------------------------------------------------------------------
--- 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) 
-
-getConType :: Name -> C Type
-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)
-        
-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)
-
-
--------------------------------------------------------------------------------
--- Defining Context
---------------------------------------------------------------------------------
-
-
-data Context = Ctx
-    { ctx_bindings :: !(Map.Map Name Rules)
-    -- mapping a function name to its clauses
-    , ctx_types    :: !(Map.Map Name Type)
-    -- mapping a function name to its type
-    , ctx_ctors    :: !(Map.Map Name Type)
-    -- mapping a constructor name to its type
-    , ctx_classes  :: !(Map.Map Name [Name])
-    -- mapping a class name to its superclasses
-    , ctx_members  :: !(Map.Map Name [Name])
-    -- mapping a class name to the name of its member functions
-    , ctx_instances  :: !(Map.Map Type [Name])
-    -- mapping a type to its classes, of which it is a member   
-    , ctx_typesyns  :: !(Map.Map  Type Type)
-}deriving(Show)
-
-
-
-addToBindings :: [(Name, Rules)] -> Context -> Context
-addToBindings l c = foldl add c l 
-    where
-    add ctx (n,cs) = 
-        let bindings = ctx_bindings ctx
-        in ctx{ctx_bindings = Map.insert n cs bindings}
-
-addToTypes :: [(Name, Type)] -> Context -> Context
-addToTypes l c  = foldl add c l 
-    where    
-    add ctx (n, ty) =
-        let types = ctx_types ctx 
-        in ctx{ctx_types = Map.insert n ty types}    
-
-addToConstructors :: [(Name, Type)] -> Context -> Context
-addToConstructors l c  =  foldl add c l
-    where    
-    add ctx (n, ty) =
-        let ctors = ctx_ctors ctx 
-        in ctx{ctx_ctors = Map.insert n ty ctors}
-            
-addToClasses :: [(Name, [Name])] -> Context -> Context
-addToClasses l c  = foldl add c l 
-    where
-    add ctx (n, ns) = 
-        let classes = ctx_classes ctx 
-        in ctx{ctx_classes = Map.insert n ns classes} 
-             
-addToMembers :: [(Name, [Name])] -> Context -> Context
-addToMembers l c  = foldl add c l 
-    where
-    add ctx (n, ns) = 
-        let members = ctx_members ctx 
-        in ctx{ctx_members = Map.insert n ns members}       
-     
-addToInstances :: [(Type, Name)] -> Context -> Context
-addToInstances l c  = foldl add c l 
-    where
-    add ctx (ty, n) = 
-        let insts = ctx_instances ctx
-        in ctx{ctx_instances = Map.insertWith (++) ty [n] insts}    
-
-addToTypeSyns :: [(Type, Type)] -> Context -> Context
-addToTypeSyns l c  = foldl add c l 
-    where
-    add ctx (syn, ty) =
-        let tysyns = ctx_typesyns ctx
-        in  
-        ctx{ctx_typesyns = Map.insert syn ty tysyns}    
-    
-
-    
-instance Pretty Context where
-    pretty ctx = linebreak <$> text "Context: " <$>
-               (indent 2 $ text "Bindings: " <$> pretty (ctx_bindings ctx) <$>
-                           text "Types   : " <$> pretty (ctx_types ctx) <$>
-                           text "Ctors   : " <$> pretty (ctx_ctors ctx) <$>
-                           text "Classes : " <$> pretty (ctx_classes ctx) <$>
-                           text "Members : " <$> pretty (ctx_members ctx) <$>
-                           text "Instancs: " <$> pretty (ctx_instances ctx) <$>
-                           text "Synonyms: " <$> pretty (ctx_typesyns ctx))
-        
-    
-defaultContext = Ctx 
-    { ctx_bindings  = defaultbindings
-    , ctx_types     = defaulttypes
-    , ctx_ctors     = defaultctors
-    , ctx_classes   = defaultclasses
-    , ctx_members   = defaultmembers
-    , ctx_instances = defaultinstances
-    , ctx_typesyns = defaulttypesyns
-}
-
-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"])
-    ,(mkName "Eq",[])]
-defaultmembers   = Map.empty
-defaultinstances = Map.empty
-defaulttypesyns  = Map.empty
-
-mkVarT = VarT . mkName
-             
-emptyCtx = Ctx 
-    { ctx_bindings  = Map.empty
-    , ctx_types     = Map.empty
-    , ctx_ctors     = Map.empty
-    , ctx_classes   = Map.empty
-    , ctx_members   = Map.empty
-    , ctx_instances = Map.empty
-    , ctx_typesyns = Map.empty
-} 
-
---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 
---    }
- 
+  
addfile ./src/Context/ModuleContext.hs
hunk ./src/Context/ModuleContext.hs 1
+{-# OPTIONS_GHC -fglasgow-exts -XTemplateHaskell #-}
+module Context.ModuleContext where
+
+import qualified Data.Map as Map
+import Syntax.IFTemplateHaskell
+import Syntax.Patterns
+import Syntax.Expressions
+import qualified Context.SynthesisContext as SC
+import Logging
+
+
+type Rule = ([TPat],TExp)
+type Rules = [Rule]
+-------------------------------------------------------------------------------
+-- Defining Context
+--------------------------------------------------------------------------------
+
+
+data ModuleCtx = MCtx
+    { mctx_bindings :: !(Map.Map Name Rules)
+    -- mapping a function name to its clauses
+    , mctx_synctx   :: !SC.SynCtx
+    }deriving(Show)
+mctx_types     = SC.sctx_types . mctx_synctx
+mctx_ctors     = SC.sctx_ctors . mctx_synctx
+mctx_classes   = SC.sctx_classes . mctx_synctx
+mctx_members   = SC.sctx_members . mctx_synctx
+mctx_instances = SC.sctx_instances . mctx_synctx
+mctx_typesyns  = SC.sctx_typesyns . mctx_synctx
+
+
+
+addToBindings :: [(Name, Rules)] -> ModuleCtx -> ModuleCtx
+addToBindings l c = foldl add c l 
+    where
+    add ctx (n,cs) = 
+        let bindings = mctx_bindings ctx
+        in ctx{mctx_bindings = Map.insert n cs bindings}
+
+addToTypes :: [(Name, Type)] -> ModuleCtx -> ModuleCtx
+addToTypes l c  = 
+    let sctx = mctx_synctx c
+    in c{mctx_synctx = SC.addToTypes l sctx}   
+
+addToConstructors :: [(Name, Type)] -> ModuleCtx -> ModuleCtx
+addToConstructors l c  =  
+    let sctx = mctx_synctx c
+    in c{mctx_synctx = SC.addToConstructors l sctx}   
+            
+addToClasses :: [(Name, [Name])] -> ModuleCtx -> ModuleCtx
+addToClasses l c  = 
+    let sctx = mctx_synctx c
+    in c{mctx_synctx = SC.addToClasses l sctx}   
+             
+addToMembers :: [(Name, [Name])] -> ModuleCtx -> ModuleCtx
+addToMembers l c  = 
+    let sctx = mctx_synctx c
+    in c{mctx_synctx = SC.addToMembers l sctx}       
+     
+addToInstances :: [(Type, Name)] -> ModuleCtx -> ModuleCtx
+addToInstances l c  = 
+    let sctx = mctx_synctx c
+    in c{mctx_synctx = SC.addToInstances l sctx}   
+
+addToTypeSyns :: [(Type, Type)] -> ModuleCtx -> ModuleCtx
+addToTypeSyns l c  = 
+    let sctx = mctx_synctx c
+    in c{mctx_synctx = SC.addToTypeSyns l sctx}   
+    
+
+    
+instance Pretty ModuleCtx where
+    pretty ctx = linebreak <$> text "Context: " <$>
+               (indent 2 $ text "Bindings: " <$> pretty (mctx_bindings ctx) <$>
+                           text "Types   : " <$> pretty (mctx_types ctx) <$>
+                           text "Ctors   : " <$> pretty (mctx_ctors ctx) <$>
+                           text "Classes : " <$> pretty (mctx_classes ctx) <$>
+                           text "Members : " <$> pretty (mctx_members ctx) <$>
+                           text "Instancs: " <$> pretty (mctx_instances ctx) <$>
+                           text "Synonyms: " <$> pretty (mctx_typesyns ctx))
+        
+    
+defaultContext = MCtx 
+    { mctx_bindings  = defaultbindings
+    , mctx_synctx    = SC.defaultSynCtx
+}
+defaultbindings = Map.empty
+            
+emptyCtx = MCtx 
+    { mctx_bindings  = Map.empty
+    , mctx_synctx    = SC.emptySynCtx
+} 
+
+
+-------------------------------------------------------------------------------
+-- Using Context
+--------------------------------------------------------------------------------
+
+type C a = (StateT ModuleCtx (Either String)) a
+
+getVarType :: (MonadState ModuleCtx m) => Name -> m Type
+getVarType n = do
+    m <- gets mctx_types
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Variable not in context: " ++ (show n) 
+
+getConType :: (MonadState ModuleCtx m) => Name -> m Type
+getConType n = do
+    m <- gets mctx_ctors 
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Ctor not in context: " ++ (show n)
+        
+getSubClasses :: (MonadState ModuleCtx m) => Name -> m [Name]        
+getSubClasses n = do
+    m <- gets mctx_classes
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Class not in context: " ++ (show n)
+        
+getInstances :: (MonadState ModuleCtx m) => Type -> m [Name]        
+getInstances n = do
+    m <- gets mctx_instances
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Type not in context: " ++ (show n)
addfile ./src/Context/SynthesisContext.hs
hunk ./src/Context/SynthesisContext.hs 1
+{-# OPTIONS_GHC -fglasgow-exts -XTemplateHaskell #-}
+module Context.SynthesisContext  where
+
+import qualified Data.Map as Map
+import Syntax.IFTemplateHaskell
+import Logging
+import Control.Monad.State
+-------------------------------------------------------------------------------
+-- Defining Context
+--------------------------------------------------------------------------------
+
+
+data SynCtx = SCtx
+    { sctx_types    :: !(Map.Map Name Type)
+    -- mapping a function name to its type
+    , sctx_ctors    :: !(Map.Map Name Type)
+    -- mapping a constructor name to its type
+    , sctx_classes  :: !(Map.Map Name [Name])
+    -- mapping a class name to its superclasses
+    , sctx_members  :: !(Map.Map Name [Name])
+    -- mapping a class name to the name of its member functions
+    , sctx_instances  :: !(Map.Map Type [Name])
+    -- mapping a type to its classes, of which it is a member   
+    , sctx_typesyns  :: !(Map.Map  Type Type)
+}deriving(Show)
+
+
+addToTypes :: [(Name, Type)] -> SynCtx -> SynCtx
+addToTypes l c  = foldl add c l 
+    where    
+    add ctx (n, ty) =
+        let types = sctx_types ctx 
+        in ctx{sctx_types = Map.insert n ty types}    
+
+addToConstructors :: [(Name, Type)] -> SynCtx -> SynCtx
+addToConstructors l c  =  foldl add c l
+    where    
+    add ctx (n, ty) =
+        let ctors = sctx_ctors ctx 
+        in ctx{sctx_ctors = Map.insert n ty ctors}
+            
+addToClasses :: [(Name, [Name])] -> SynCtx -> SynCtx
+addToClasses l c  = foldl add c l 
+    where
+    add ctx (n, ns) = 
+        let classes = sctx_classes ctx 
+        in ctx{sctx_classes = Map.insert n ns classes} 
+             
+addToMembers :: [(Name, [Name])] -> SynCtx -> SynCtx
+addToMembers l c  = foldl add c l 
+    where
+    add ctx (n, ns) = 
+        let members = sctx_members ctx 
+        in ctx{sctx_members = Map.insert n ns members}       
+     
+addToInstances :: [(Type, Name)] -> SynCtx -> SynCtx
+addToInstances l c  = foldl add c l 
+    where
+    add ctx (ty, n) = 
+        let insts = sctx_instances ctx
+        in ctx{sctx_instances = Map.insertWith (++) ty [n] insts}    
+
+addToTypeSyns :: [(Type, Type)] -> SynCtx -> SynCtx
+addToTypeSyns l c  = foldl add c l 
+    where
+    add ctx (syn, ty) =
+        let tysyns = sctx_typesyns ctx
+        in  
+        ctx{sctx_typesyns = Map.insert syn ty tysyns}    
+    
+
+    
+instance Pretty SynCtx where
+    pretty ctx = linebreak <$> text "SynCtx: " <$>
+               (indent 2 $ text "Types   : " <$> pretty (sctx_types ctx) <$>
+                           text "Ctors   : " <$> pretty (sctx_ctors ctx) <$>
+                           text "Classes : " <$> pretty (sctx_classes ctx) <$>
+                           text "Members : " <$> pretty (sctx_members ctx) <$>
+                           text "Instancs: " <$> pretty (sctx_instances ctx) <$>
+                           text "Synonyms: " <$> pretty (sctx_typesyns ctx))
+        
+    
+defaultSynCtx = SCtx 
+    { sctx_types     = defaulttypes
+    , sctx_ctors     = defaultctors
+    , sctx_classes   = defaultclasses
+    , sctx_members   = defaultmembers
+    , sctx_instances = defaultinstances
+    , sctx_typesyns = defaulttypesyns
+}
+
+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"])
+    ,(mkName "Eq",[])]
+defaultmembers   = Map.empty
+defaultinstances = Map.empty
+defaulttypesyns  = Map.empty
+
+mkVarT = VarT . mkName
+             
+emptySynCtx = SCtx 
+    { sctx_types     = Map.empty
+    , sctx_ctors     = Map.empty
+    , sctx_classes   = Map.empty
+    , sctx_members   = Map.empty
+    , sctx_instances = Map.empty
+    , sctx_typesyns = Map.empty
+} 
+
+--mergeCtx :: SynCtx -> SynCtx -> SynCtx
+--mergeCtx c1 c2 = Ctx
+--    { sctx_bindings  = (Map.union `on` sctx_bindings) c1 c2
+--    , sctx_types     = (Map.union `on` sctx_types) c1 c2
+--    , sctx_ctors     = (Map.union `on` sctx_ctors) c1 c2
+--    , sctx_classes   = ((Map.unionWith (++)) `on` sctx_classes) c1 c2
+--    , sctx_members   = (Map.union `on` sctx_members) c1 c2
+--    , sctx_instances = ((Map.unionWith (++)) `on` sctx_instances) c1 c2
+--    , sctx_typesyns  = (Map.union `on` sctx_typesyns) c1 c2 
+--    }
+
+--------------------------------------------------------------------------------
+-- a Monad with SynCtx
+--------------------------------------------------------------------------------
+
+type SC m = (StateT SynCtx m) 
+type SCLM = SC LM
+
+execSCT = runStateT
+
+
+getVarType :: (MonadState SynCtx m) => Name -> m Type
+getVarType n = do
+    m <- gets sctx_types
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Variable not in context: " ++ (show n) 
+
+getConType :: (MonadState SynCtx m) => Name -> m Type
+getConType n = do
+    m <- gets sctx_ctors 
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Ctor not in context: " ++ (show n)
+        
+getSubClasses :: (MonadState SynCtx m) => Name -> m [Name]        
+getSubClasses n = do
+    m <- gets sctx_classes
+    case Map.lookup n m of
+        (Just t) -> return t
+        _owise   -> fail $ "Class not in context: " ++ (show n)
+        
+getInstances :: (MonadState SynCtx m) => Type -> m [Name]        
+getInstances n = do
+    m <- gets sctx_instances
+    case Map.lookup n m of
+        (Just t) -> return t
hunk ./src/UI/UIStarter.hs 13
-import UI.Context
+import Context.ContextBuilder
hunk ./src/UI/UIStarter.hs 43
-    , context :: !Context
+    , context :: !ModuleCtx