[Tidied up Class Term, removed some funs from member functions and defined them in terms of the remaining ones
martin.hofmann@uni-bamberg.de**20090409120432] hunk ./src/Syntax/Expressions.hs 9
+import Data.List (union)
hunk ./src/Syntax/Expressions.hs 71
-    
-    getPos t s | s == t     = [Root]
-               | otherwise  = 
-                    case t of
-                      (AppE e1 e2)                    -> let args = unfoldAppEargs t 
-                                                         in mapGetPos args s
-                      -- | _e is the operator (see <http://haskell.org/ghc/docs/latest/html/libraries/template-haskell/src/Language-Haskell-TH-Syntax.html#Exp>)
-                      (InfixE Nothing _e Nothing)     -> []
-                      (InfixE (Just e1) _e Nothing)   -> map (°0) (getPos e1 s)
-                      (InfixE Nothing _e (Just e2))   -> map (°1) (getPos e2 s)
-                      (InfixE (Just e1) _e (Just e2)) -> 
-                            let pos1 = map (°0) (getPos e1 s)
-                                pos2 = map (°1) (getPos e2 s)
-                            in pos1 ++ pos2
-                      (ListE [])                      -> [Root ° 0]
-                      (ListE (e1:es))                 -> mapGetPos [e1, ListE es] s  -- I HATE SYNTACTIC SUGAR!!!
-                      (TupE es)                       -> mapGetPos es s                                    
-                      _owise                          -> [] --  VarE Name, ConE Name, LitE Lit          
-                      -- These parts of the TH syntax are ignored:                      
-                      --LamE [Pat] Exp  
-                      --CondE Exp Exp Exp   
-                      --LetE [Dec] Exp  
-                      --CaseE Exp [Match]   
-                      --DoE [Stmt]  
-                      --CompE [Stmt]    
-                      --ArithSeqE Range 
-                      --SigE Exp Type   
-                      --RecConE Name [FieldExp] 
-                      --RecUpdE Exp [FieldExp]
+--    
+--    getPos t s | s == t     = [Root]
+--               | otherwise  = 
+--                    case t of
+--                      (AppE e1 e2)                    -> let args = unfoldAppEargs t 
+--                                                         in mapGetPos args s
+--                      -- | _e is the operator (see <http://haskell.org/ghc/docs/latest/html/libraries/template-haskell/src/Language-Haskell-TH-Syntax.html#Exp>)
+--                      (InfixE Nothing _e Nothing)     -> []
+--                      (InfixE (Just e1) _e Nothing)   -> map (°0) (getPos e1 s)
+--                      (InfixE Nothing _e (Just e2))   -> map (°1) (getPos e2 s)
+--                      (InfixE (Just e1) _e (Just e2)) -> 
+--                            let pos1 = map (°0) (getPos e1 s)
+--                                pos2 = map (°1) (getPos e2 s)
+--                            in pos1 ++ pos2
+--                      (ListE [])                      -> [Root ° 0]
+--                      (ListE (e1:es))                 -> mapGetPos [e1, ListE es] s  -- I HATE SYNTACTIC SUGAR!!!
+--                      (TupE es)                       -> mapGetPos es s                                    
+--                      _owise                          -> [] --  VarE Name, ConE Name, LitE Lit          
+--                      -- These parts of the TH syntax are ignored:                      
+--                      --LamE [Pat] Exp  
+--                      --CondE Exp Exp Exp   
+--                      --LetE [Dec] Exp  
+--                      --CaseE Exp [Match]   
+--                      --DoE [Stmt]  
+--                      --CompE [Stmt]    
+--                      --ArithSeqE Range 
+--                      --SigE Exp Type   
+--                      --RecConE Name [FieldExp] 
+--                      --RecUpdE Exp [FieldExp]
hunk ./src/Syntax/Expressions.hs 121
+       
+    isVar (VarE _) = True
+    isVar _        = False
hunk ./src/Syntax/Expressions.hs 125
-    varAtPos t p = 
-        case subtermAt t p of
-            Just (VarE _) -> True
-            _owise        -> False
-            
-    getVars_ done t@(VarE _)                      = S.insert t done
-    getVars_ done (ConE _)                        = done
-    getVars_ done (LitE _)                        = done
-    getVars_ done (TupE vals)                     = 
-        S.unions (done:(map (getVars_ S.empty) vals))
-    getVars_ done (AppE a1 a2)                    = 
-        S.unions (done:(map (getVars_ S.empty) [a1,a2]))                                                        
-    getVars_ done (ListE l)                       = 
-        S.unions (done:(map (getVars_ S.empty) l))
-    getVars_ done (CondE e1 e2 e3)                = 
-        S.unions (done:(map (getVars_ S.empty) [e1, e2, e3]))
-    getVars_ done (InfixE e1 e2 e3)               = 
-        S.unions $ done: 
-                   (map (getVars_ S.empty) $
-                        (maybeToList e1) ++ [e2] ++ (maybeToList e3))
+--    getVars t@(VarE _)                = [t]
+--    getVars (ConE _)                  = []
+--    getVars (LitE _)                  = []
+--    getVars (TupE vals)               = foldl1 union $ map getVars vals
+--    getVars (AppE a1 a2)              = on union getVars a1 a2                                            
+--    getVars (ListE l)                 = foldl1 union $ map getVars l
+--    getVars (CondE e1 e2 e3)          = foldl1 union $ map getVars [e1, e2, e3]
+--    getVars (InfixE e1 e2 e3)         = 
+--        foldl1 union $ map getVars $ (maybeToList e1) ++ [e2] ++ (maybeToList e3)
hunk ./src/Syntax/Patterns.hs 10
+import Data.List (union)
+import Data.Function (on)
hunk ./src/Syntax/Patterns.hs 48
-    getPos t s | s == t     = [Root]
-               | otherwise  = 
-                    case t of
-                      (ConP _ ps)                    -> mapGetPos ps s
-                      (InfixP p1 _ p2) -> 
-                            let pos1 = map (°0) (getPos p1 s)
-                                pos2 = map (°1) (getPos p2 s)
-                            in pos1 ++ pos2
-                      (ListP [])                      -> [Root ° 0]
-                      (ListP (p1:ps))                 -> mapGetPos [p1, ListP ps] s  -- I HATE SYNTACTIC SUGAR!!!
-                      (TupP ps)                       -> mapGetPos ps s                                    
-                      _owise                          -> [] --  VarP Name, LitP Lit 
-    
+--    getPos t s | s == t     = [Root]
+--               | otherwise  = 
+--                    case t of
+--                      (ConP _ ps)                    -> mapGetPos ps s
+--                      (InfixP p1 _ p2) -> 
+--                            let pos1 = map (°0) (getPos p1 s)
+--                                pos2 = map (°1) (getPos p2 s)
+--                            in pos1 ++ pos2
+--                      (ListP [])                      -> [Root ° 0]
+--                      (ListP (p1:ps))                 -> mapGetPos [p1, ListP ps] s  -- I HATE SYNTACTIC SUGAR!!!
+--                      (TupP ps)                       -> mapGetPos ps s                                    
+--                      _owise                          -> [] --  VarP Name, LitP Lit 
+--    
hunk ./src/Syntax/Patterns.hs 78
-    varAtPos t p = 
-        case subtermAt t p of
-            Just (VarP _) -> True
-            _owise        -> False
+    isVar (VarP _) = True
+    isVar _        = False
hunk ./src/Syntax/Patterns.hs 81
-    getVars_ done t@(VarP _)                     = S.insert t done
-    getVars_ done (LitP _)                       = done
-    getVars_ done (TupP ps)                      = 
-        S.unions (done:(map (getVars_ S.empty) ps))
-    getVars_ done (ConP _ ps)                    = 
-        S.unions (done:(map (getVars_ S.empty) ps))
-    getVars_ done (ListP l)                      = 
-        S.unions (done:(map (getVars_ S.empty) l))
-    getVars_ done (InfixP e1 _ e2)              = 
-        S.unions (done:(map (getVars_ S.empty) [e1, e2]))
+--    getVars t@(VarP _)                     = [t]
+--    getVars (LitP _)                       = []
+--    getVars (TupP ps)                      = foldl1 union $ map getVars ps
+--    getVars (ConP _ ps)                    = foldl1 union $ map getVars ps
+--    getVars (ListP l)                      = foldl1 union $ map getVars l
+--    getVars (InfixP e1 _ e2)               = on union getVars e1 e2 
hunk ./src/Syntax/Terms.hs 15
-    subtermAt, getVars, subtermOf, sameSymAt, getVarPos, hasVars,
+    subtermAt, subtermOf, sameSymAt, getVarPos, hasVars, getVars, getPos, varAtPos,
hunk ./src/Syntax/Terms.hs 31
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust, maybeToList)
hunk ./src/Syntax/Terms.hs 131
-    getPos          :: t                 -- ^ the term
-                    -> t                 -- ^ the subterm
-                    -> [Position]        -- ^ the positions
+--    getPos          :: t                 -- ^ the term
+--                    -> t                 -- ^ the subterm
+--                    -> [Position]        -- ^ the positions
hunk ./src/Syntax/Terms.hs 149
-    
-    getVars_        :: (S.Set t) -> t -> (S.Set t)
-    
+        
hunk ./src/Syntax/Terms.hs 153
-    varAtPos :: t -> Position -> Bool
+    isVar :: t -> Bool
hunk ./src/Syntax/Terms.hs 179
+getPos :: (Term t) => t -> t -> [Position]
+getPos t s  
+    | t == s    = [Root]
+    | otherwise = mapGetPos (subterms t) s
hunk ./src/Syntax/Terms.hs 192
--- |Returns a (unique) list of all variables in t
-getVars         :: (Term t) => t -> [t]
-getVars         = S.elems.getVars_ S.empty
hunk ./src/Syntax/Terms.hs 197
+varAtPos :: (Term t) => t -> Position -> Bool
+varAtPos t p = isJust $ liftM isVar $ subtermAt t p 
hunk ./src/Syntax/Terms.hs 203
+-- |Returns a (unique) list of all variables in t
+getVars         :: (Term t) => t -> [t]
+getVars t
+    | isVar t   = [t]
+    | otherwise = concatMap getVars $ subterms t
+
hunk ./src/Syntax/Terms.hs 224
-mapGetPos ts s = concat $ snd $ L.mapAccumL (\i t -> (i+1, map (°i) (getPos t s))) 0 ts
+mapGetPos ts s = concat $ snd $ L.mapAccumR (\i t -> (i+1, map (°i) (getPos t s))) 0 ts
hunk ./src/Syntax/Types.hs 6
+import Syntax.Terms
hunk ./src/Syntax/Types.hs 25
+instance Term Type where
+    sameSymAtRoot t1 t2 = error "sameSymAtRoot for Type not imlemented"
+    subterms _ =  error "subterms for Type not imlemented"
+    substitute _ _ _ =  error "substitute for Type not imlemented"
+    
+    isVar (VarT _) = True
+    isVar _        = False
+    
+--    getVars t@(VarT _) = [t]
+--    getVars (AppT t1 t2) = (getVars t1) `union` (getVars t2)
+--    getVars _   = [] -- VarT, ConT, TupltT, ArrowT,ListT
+    
+    getVarNames = (map (\(VarT n) -> n)) . getVars 
+    
+    hole =  ConT ''Hole
+    
hunk ./src/Syntax/Types.hs 63
-    where 
+    where  
hunk ./src/Syntax/Types.hs 83
-
hunk ./src/Syntax/Types.hs 84
+-- | instantiating Type 't2' with Type 't1', where 't2' contains type variables
+--   which are to instantiate using 't1'. E.g.
+--   @specialise '[Int]' '(b,a) -> (a,String) -> [a]' is '(b,Int) -> (Int,String) -> [Int]@
+instantiate :: (Monad m) => Type -> Type -> m Type
+  
+instantiate t1 t2 =  return t2
hunk ./src/UI/Context.hs 38
-                        fail $ "Parsing failed at " ++ (show sloc) ++ " with message: " ++ msg  
+                        fail $ "Parsing failed at " ++ (show sloc) ++ 
+                               " with message: " ++ msg  
hunk ./src/UI/Context.hs 61
+--buildCtx ctx (Hs.ClassDecl sloc _ _ [] _ _) = can never be
+buildCtx ctx (Hs.ClassDecl sloc _ _ (_:_:_) _ _) =
+    fail $  fail $ "Multi parameter type classes are not supported at: " ++ (show sloc)        
hunk ./src/UI/Context.hs 82
-      
-buildCtx ctx (Hs.InstDecl sloc assts qname types _) = 
-    case types of
-        [t] -> let ty = mkForallT assts (T.toType t)
-                   -- the type of the class instance
-                   n = T.toName qname
-                   -- the name of the class
-               in return $ addToInstances [(ty,n)] ctx 
-        ts    -> fail $ "Multi parameter type classes are not supported at: " ++ (show sloc)   
+
+--buildCtx _ (Hs.InstDecl sloc _ _ [] _) -- can never be 
+buildCtx _ (Hs.InstDecl sloc _ _ (_:_:_) _) =      
+    fail $ "Multi parameter type classes are not supported at: " ++ (show sloc)
+buildCtx ctx (Hs.InstDecl sloc assts qname [t] _) = do 
+    let ty = mkForallT assts (T.toType t)
+        -- the type of the class instance
+        n = T.toName qname
+        -- the name of the class
+    return $ addToInstances [(ty,n)] ctx   
hunk ./src/UI/Context.hs 207
-        _owise   -> fail $ "Variable not in context: " ++ (show n)
---    return $ fromMaybe (fail $ "variable not in context " ++ (show n)) $  
+        _owise   -> fail $ "Variable not in context: " ++ (show n) 
hunk ./src/UI/Context.hs 214
-        
+
+
+-- | Propagates a type to an expression and all its subexpressions. 
+--   No type checking is done !!         
hunk ./src/UI/Context.hs 220
+    
+-- | Propagates a type to a pattern and all its subpatterns. 
+--   No type checking is done !!
hunk ./src/UI/Context.hs 290
-    toTPat _ p = fail $ "No Translation defined for " ++ (show p)      
---          | TInfixP TPat Name TPat
+    toTPat _ p = fail $ "No Translation defined for " ++ (show p)    
+
+-- | specialising Type 't2' using Type 't1', where 't2' contains type variables
+--   which are to instantiate using 't1'. E.g.
+--   @specialise '[Int]' '(b,a) -> (a,String) -> [a]' is '(b,Int) -> (Int,String) -> [Int]@ 
+
+specialise t1 t2 =  return t2
hunk ./src/UI/Context.hs 298
-specialise t a =  return a
hunk ./src/UI/Context.hs 426
-    [(mkName "Ord",[mkName "Eq"])]
+    [(mkName "Ord",[mkName "Eq"])
+    ,(mkName "Eq",[])]
hunk ./src/UI/UIStarter.hs 151
-    (indent 2 $ vcat [ fill 25 (text $ (if getter s then "+" else "-") ++ name) <> text descr|
-                    (name, descr, getter, _setter) <- flags ] <$>
+    (indent 2 $ 
+                vcat [ fill 25 ((fill 15 (text name) <> text " = ") <> text (show (getter s))) <> text descr |
+                    (name,descr,getter,_setter) <- flags] <$>
+--                vcat [ fill 25 (text $ (if getter s then "+" else "-") ++ name) <> text descr|
+--                    (name, descr, getter, _setter) <- flags ] <$>
hunk ./src/UI/UIStarter.hs 185
+ | Test String Int