[Translator collects all necessary context information from a file
martin.hofmann@uni-bamberg.de**20090403101813] addfile ./src/Syntax/Translator.hs
hunk ./src/Syntax/Translator.hs 1
-
+
+module Syntax.Translator where
+
+import Language.Haskell.Meta.Parse
+import qualified Language.Haskell.Meta.Syntax.Translate as T
+
+import Language.Haskell.Exts.Parser hiding (parseModule)
+import qualified Language.Haskell.Exts.Syntax as Hs
+import Language.Haskell.Exts.Pretty
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import qualified Data.Map as Map
+
+import Control.Monad (foldM)
+import Syntax.Class -- for Ord Type
+import Logging
+
+
+parseContext :: String ->  IO Context
+parseContext s = do 
+    (ParseOk mdule) <- parseFile s
+    foldM buildCtx emptyCtx $ moduleDecls  mdule 
+
+buildCtx :: Context -> Hs.Decl -> IO Context
+buildCtx ctx d@(Hs.TypeDecl _  _ _ _) = 
+    let pSynTy = map (\(TySynD n args t) ->  ((mkAppT n args), t) ) $ toDec d
+    in return $ addToTypeSyns pSynTy ctx
+    
+buildCtx ctx (Hs.DataDecl _ _ assts tname args condecls derive) =
+    let dataty = mkHsTyApp tname args
+        -- build the type of the given data type
+        ctorty = \ty -> (mkForallT assts (T.toType $ mkHsTyFun (ty ++ [dataty])))
+        -- for a given list of ctor argument typess it creates a function type 
+        ctorNameTy cd  = case cd of 
+            (Hs.QualConDecl _ _ _ (Hs.ConDecl n tys)) -> ( T.toName n, ctorty $ map unBang tys);
+             _owise -> error $ "No records supported!"
+        -- extracts the name and the type of a constructor from a 'ConDecl'    
+        pNameTy = map ctorNameTy condecls
+        -- pairs of function names and the types of accordant function 
+        pTysClass = map (\(n,_) ->  ((mkForallT assts (T.toType dataty)), (T.toName n))) derive
+        -- pairs of types 't' and class name 'c', denoting 't' isInstanceOf 'c'
+    in return $ (addToTypes 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)
+        -- extract plain class declarations, i.e. no 'ClsDataFam', 'ClsTyFam', 'ClsTyDef' 
+        isTypeDecl d = case d of (Hs.TypeSig _ _ _) -> True; _owise -> False
+        assts'       = (mkHsAsst cname anames):assts 
+        -- add actual class as additional assertion predicate in the signature of
+        -- the class member functions
+        pNameTy     = map (\(SigD n t) -> (n, (mkForallT assts' t))) sigds
+        -- pairs of function names and the types of accordant function 
+        pClssFuns     = [(T.toName cname,[ n | (SigD n _) <- sigds])]
+        -- pairs of a class name and a list of names of its member functions
+    in return $ (addToTypes pNameTy ) . (addToClasses pClssFuns) $ ctx 
+      
+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    -> error $ "Multi parameter type classes are not supported at: " ++ (show sloc)   
+    
+buildCtx ctx d@(Hs.TypeSig _ _ _ ) =
+    let pNmsTys  = map (\(SigD n t) -> (n,t)) $ toDec d  
+    in return $ addToTypes pNmsTys ctx
+ 
+buildCtx ctx d@(Hs.FunBind _ ) = 
+    let [(FunD n cls)] = toDec d
+    in  return $ addToBindings [(n,cls)] ctx
+    
+buildCtx e (Hs.GDataDecl sloc _ _ _ _ _ _ _ ) = do
+    putStrLn $ "...Skipping GDataDecl at " ++ (show sloc)
+    return e    
+buildCtx e (Hs.TypeFamDecl sloc _ _ _ ) = do
+    putStrLn $ "...Skipping TypeFamDecl at " ++ (show sloc)
+    return e    
+buildCtx e (Hs.DataFamDecl sloc _ _ _ _ ) = do
+    putStrLn $ "...Skipping DataFamDecl at " ++ (show sloc)
+    return e     
+buildCtx e (Hs.TypeInsDecl sloc _ _ ) = do
+    putStrLn $ "...Skipping TypeInsDecl at " ++ (show sloc)
+    return e         
+buildCtx e (Hs.DataInsDecl sloc _ _ _ _ ) = do
+    putStrLn $ "...Skipping DataInsDecl at " ++ (show sloc)
+    return e           
+buildCtx e (Hs.GDataInsDecl sloc _ _ _ _ _ ) = do
+    putStrLn $ "...Skipping GDataInsDecl at " ++ (show sloc)
+    return e            
+buildCtx e (Hs.InfixDecl sloc _ _ _ ) = do
+    putStrLn $ "...Skipping InfixDecl at " ++ (show sloc)
+    return e      
+buildCtx e (Hs.DerivDecl sloc _ _ _ ) = do
+    putStrLn $ "...Skipping DerivDecl at " ++ (show sloc)
+    return e               
+buildCtx e (Hs.DefaultDecl sloc _ ) = do
+    putStrLn $ "...Skipping DefaultDecl at " ++ (show sloc)
+    return e               
+buildCtx e (Hs.SpliceDecl sloc _ ) = do
+    putStrLn $ "...Skipping SpliceDecl at " ++ (show sloc)
+    return e              
+buildCtx e (Hs.PatBind sloc _ _ _ _ ) = do
+    putStrLn $ "...Skipping PatBind at " ++ (show sloc)
+    return e               
+buildCtx e (Hs.ForImp sloc _ _ _ _ _ ) = do
+    putStrLn $ "...Skipping ForImp at " ++ (show sloc)
+    return e              
+buildCtx e (Hs.ForExp sloc _ _ _ _ ) = do
+    putStrLn $ "...Skipping ForExp at " ++ (show sloc)
+    return e             
+buildCtx e (Hs.RulePragmaDecl sloc _ ) = do
+    putStrLn $ "...Skipping RulePragmaDecl at " ++ (show sloc)
+    return e                
+buildCtx e (Hs.DeprPragmaDecl sloc _ ) = do
+    putStrLn $ "...Skipping DeprPragmaDecl at " ++ (show sloc)
+    return e                
+buildCtx e (Hs.WarnPragmaDecl sloc _ ) = do
+    putStrLn $ "...Skipping GDataInsDecl at " ++ (show sloc)
+    return e                
+buildCtx e (Hs.InlineSig sloc _ _ _ ) = do
+    putStrLn $ "...Skipping InlineSig at " ++ (show sloc)
+    return e              
+buildCtx e (Hs.SpecSig sloc _ _ ) = do
+    putStrLn $ "...Skipping SpecSig at " ++ (show sloc)
+    return e             
+buildCtx e (Hs.SpecInlineSig sloc _ _ _ _ ) = do
+    putStrLn $ "...Skipping SpecInlineSig at " ++ (show sloc)
+    return e               
+buildCtx e (Hs.InstSig sloc _ _ _ ) = do
+    putStrLn $ "...Skipping InstSig at " ++ (show sloc)
+    return e             
+buildCtx e (Hs.UnknownDeclPragma sloc _ _ ) = do
+    putStrLn $ "...Skipping UnknownDeclPragma at " ++ (show sloc)
+    return e            
+
+toDec :: Hs.Decl -> [Dec]
+toDec (Hs.TypeSig _ ns t) =  [SigD (T.toName n) (T.toType t) | n <- ns]
+toDec decs                = [T.toDec decs] 
+                        -- is a 'FunBind' or 'TySynD' or something is wrong 
+
+
+mkAppT n ns = foldl AppT (ConT n) (map VarT ns)
+
+mkHsTyApp n as = foldl Hs.TyApp (Hs.TyCon $ Hs.UnQual n) (map Hs.TyVar as)
+
+mkHsTyFun = foldr1 Hs.TyFun
+
+mkHsAsst ctor args = Hs.ClassA (Hs.UnQual ctor) (map Hs.TyVar args)
+
+unBang ty = case ty of 
+            (Hs.BangedTy t) -> t 
+            (Hs.UnBangedTy t) -> t
+            (Hs.UnpackedTy t) -> t
+
+mkForallT assts ty   = ForallT [] (map T.toType assts) ty             
+-------------------------------------------------------------------------------
+-- Context
+--------------------------------------------------------------------------------
+
+
+data Context = Ctx
+    { ctx_bindings :: Map.Map Name [Clause]
+    -- mapping a function name to its clauses
+    , ctx_types    :: Map.Map Name Type
+    -- mapping a function/constructor name to its type
+    , ctx_classes  :: 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 whic it is a member   
+    , ctx_typesyns  :: Map.Map  Type Type
+}--deriving(Show)
+
+
+
+addToBindings l c = foldl add c l 
+    where
+    add ctx@(Ctx bindings _ _ _ _ ) (n,cs) = 
+        ctx{ctx_bindings = Map.insert n cs bindings}
+
+addToTypes l c  = foldl add c l  
+    where
+    add ctx@(Ctx _ types _ _ _ ) (n, ty) = 
+        ctx{ctx_types = Map.insert n ty types}    
+
+addToClasses l c  = foldl add c l 
+    where
+    add ctx@(Ctx _ _ classes _ _ ) (n, ns) = 
+        ctx{ctx_classes = Map.insert n ns classes}    
+     
+addToInstances l c  = foldl add c l 
+    where
+    add ctx@(Ctx _ _ _ inst _ ) (ty, n) = 
+        ctx{ctx_instances = Map.insertWith (++) ty [n] inst}    
+
+addToTypeSyns l c  = foldl add c l 
+    where
+    add ctx@(Ctx _ _ _ _ tysyns ) (syn, ty) = 
+        ctx{ctx_typesyns = Map.insert syn ty tysyns}    
+    
+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  ClssMems: " ++ (show . pretty . ctx_instances $ ctx) ++
+               "\n  TypeSyns: " ++ (show . pretty . ctx_typesyns $ ctx) ++
+               "\n"
+    
+    
+defaultContext = emptyCtx
+
+
+             
+emptyCtx = Ctx 
+    { ctx_bindings  = Map.empty
+    , ctx_types     = Map.empty
+    , ctx_classes   = Map.empty
+    , ctx_instances = Map.empty
+    , ctx_typesyns = Map.empty
+} 
hunk ./src/UI/UIStarter.hs 13
+import Syntax.Translator
hunk ./src/UI/UIStarter.hs 41
+    , context :: Context
hunk ./src/UI/UIStarter.hs 50
+    , context   = defaultContext
hunk ./src/UI/UIStarter.hs 103
+runCmd s (Load path) = do
+    ctx <- parseContext path
+    return (False,s{context=ctx})
+runCmd s Clear  = return (False, s{context=defaultContext})
hunk ./src/UI/UIStarter.hs 153
-    [ "    " ++ name ++ replicate (10 - length name) ' ' ++  " = " 
+    ["    " ++ name ++ replicate (10 - length name) ' ' ++  " = " 
hunk ./src/UI/UIStarter.hs 155
-                    (name,descr,getter,_setter) <- options]
+                    (name,descr,getter,_setter) <- options] ++
+    ["    " ++ (show (context s))] 
hunk ./src/UI/UIStarter.hs 182
+ | Clear
hunk ./src/UI/UIStarter.hs 192
-    , (":load \"path/to/file\"",        "Load a spec file",             stringLiteral >>= return . Load)
+    , (":load \"path/to/file\"",        "Load a spec file.",             stringLiteral >>= return . Load)
+    , (":clear",                        "Clear the current context.",   return Clear)