Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fixing a few translation problems

  • Loading branch information...
commit 41a7b264ecaaa707484ca1b828ed03bfa0068df6 1 parent 4574b61
@scottgw authored
Showing with 137 additions and 60 deletions.
  1. +6 −2 ClassEnv.hs
  2. +1 −1  DepGen.hs
  3. +33 −24 Domain.hs
  4. +97 −33 Main.hs
View
8 ClassEnv.hs
@@ -9,14 +9,18 @@ import Language.Eiffel.TypeCheck.Class
import Language.Eiffel.TypeCheck.TypedExpr as T
newtype ClassEnv body expr = ClassEnv (Map String (AbsClas body expr))
+ deriving Show
type TInterEnv = ClassEnv EmptyBody T.TExpr
type InterEnv = ClassEnv EmptyBody Expr
-
makeEnv :: [AbsClas body expr] -> ClassEnv body expr
makeEnv = ClassEnv . Map.fromList . map (\c -> (map toLower (className c), c))
+-- |All keys' class-names in the class environment
+envKeys :: ClassEnv body expr -> [String]
+envKeys (ClassEnv m) = Map.keys m
+
-- |Lookup a class name in the environment. This name should be lower-case,
-- and the function takes care of common type synonyms
@@ -28,4 +32,4 @@ envLookup name e@(ClassEnv m) =
]
in case lookup name translate of
Just alias -> Map.lookup alias m
- Nothing -> Map.lookup name m
+ Nothing -> Map.lookup (map toLower name) m
View
2  DepGen.hs
@@ -66,7 +66,7 @@ depFeatures c acc = foldM depFeature acc (allFeatures c)
depAttrs :: ClasInterface -> [ClassOrGeneric] -> DepM [ClassOrGeneric]
depAttrs c = depDecls (map attrDecl $ allAttributes c)
-depFeature :: [ClassOrGeneric] -> FeatureEx -> DepM [ClassOrGeneric]
+depFeature :: [ClassOrGeneric] -> FeatureEx Expr -> DepM [ClassOrGeneric]
depFeature acc f =
let fSig = Decl (featureName f) (featureResult f)
allDecls = fSig : featureArgs f
View
57 Domain.hs
@@ -43,7 +43,7 @@ thisDecl cls = D.Decl "this" (StructType (className cls) undefined)
fromClause :: E.Clause TExpr -> D.Clause D.Expr
fromClause (E.Clause tagMb expr) =
let tag = fromMaybe "no_tag" tagMb
- in D.Clause tag (teToD expr)
+ in D.Clause tag (teToDCurr expr)
fromRoutine :: AbsClas body TExpr -> AbsRoutine abs TExpr -> Either ProcedureU ProcedureU
fromRoutine clas rtn =
@@ -56,32 +56,41 @@ fromRoutine clas rtn =
E.NoType -> Left prcd
_ -> Right prcd
-teToD :: TExpr -> D.Expr
-teToD te = go (contents te)
+teToDCurr = teToD (D.Var "this")
+
+teToD :: D.Expr -> TExpr -> D.Expr
+teToD curr' te = go curr' (contents te)
where
- go (T.Call trg name args _) = D.Call name (teToD trg : map teToD args)
- go (T.Access trg name _) = D.Access (teToD trg) name
- go (T.EqExpr op e1 e2) = D.BinOpExpr (dEqOp op) (teToD e1) (teToD e2)
- go (T.Old e) = D.UnOpExpr D.Old (teToD e)
- go (T.CurrentVar _) = D.Var "this"
- go (T.Attached _ e _) =
+ go' curr = go curr . contents
+
+ go :: D.Expr -> UnPosTExpr -> D.Expr
+ go curr (T.Call trg name args _) =
+ let dtrg = go' curr trg
+ ClassType cn _ = texpr trg
+ in D.Call (cn ++ "_" ++ name) (dtrg : map (go' dtrg) args)
+ go curr (T.Access trg name _) = D.Access (go' curr trg) name
+ go curr (T.EqExpr op e1 e2) =
+ D.BinOpExpr (dEqOp op) (go' curr e1) (go' curr e2)
+ go curr (T.Old e) = D.UnOpExpr D.Old (go' curr e)
+ go curr (T.CurrentVar _) = curr
+ go curr (T.Attached _ e _) =
let ClassType cn _ = texprTyp (contents e)
structType = D.StructType cn []
- in D.BinOpExpr (D.RelOp D.Neq structType) (teToD e) D.LitNull
- go (T.Box _ e) = teToD e
- go (T.Unbox _ e) = teToD e
- go (T.Cast _ e) = teToD e
- go (T.Var n _) = D.Var n
- go (T.ResultVar _) = D.ResultVar
- go (T.LitInt i) = D.LitInt i
- go (T.LitBool b) = D.LitBool b
- go (T.LitVoid _) = D.LitNull
- go (T.LitChar _) = error "teToD: unimplemented LitChar"
- go (T.LitString _) = error "teToD: unimplemented LitString"
- go (T.LitDouble _) = error "teToD: unimplemented LitDouble"
- go (T.Agent _ _ _ _) = error "teToD: unimplemented Agent"
- go (T.Tuple _) = error "teToD: unimplemented Tuple"
- go (T.LitArray _) = error "teToD: unimplemented LitArray"
+ in D.BinOpExpr (D.RelOp D.Neq structType) (go' curr e) D.LitNull
+ go curr (T.Box _ e) = go' curr e
+ go curr (T.Unbox _ e) = go' curr e
+ go curr (T.Cast _ e) = go' curr e
+ go _curr (T.Var n _) = D.Var n
+ go _curr (T.ResultVar _) = D.ResultVar
+ go _curr (T.LitInt i) = D.LitInt i
+ go _curr (T.LitBool b) = D.LitBool b
+ go _curr (T.LitVoid _) = D.LitNull
+ go _curr (T.LitChar _) = error "teToD: unimplemented LitChar"
+ go _curr (T.LitString _) = error "teToD: unimplemented LitString"
+ go _curr (T.LitDouble _) = error "teToD: unimplemented LitDouble"
+ go _curr (T.Agent _ _ _ _) = error "teToD: unimplemented Agent"
+ go _curr (T.Tuple _) = error "teToD: unimplemented Tuple"
+ go _curr (T.LitArray _) = error "teToD: unimplemented LitArray"
dEqOp o = D.RelOp (rel o) D.NoType
where
View
130 Main.hs
@@ -1,9 +1,16 @@
module Main where
-import Data.Either
+import Control.Applicative
+
+import Data.Binary
+import qualified Data.ByteString.Lazy as BS
import Data.List
+
import qualified Data.Map as Map
-import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+
import Data.Maybe
import Language.Eiffel.Parser.Parser
@@ -13,6 +20,8 @@ import Language.Eiffel.Position
import qualified Language.Eiffel.PrettyPrint as PP
import Language.Eiffel.TypeCheck.Class
+import Language.Eiffel.TypeCheck.Expr (flatten)
+import Language.Eiffel.TypeCheck.Context
import Language.Eiffel.TypeCheck.TypedExpr as T
import qualified Language.DemonL.AST as D
@@ -26,31 +35,48 @@ import DepGen
import Domain
import GenerateSummaries
-main :: IO ()
-main = do
- currDir <- getCurrentDirectory
- let testDir = currDir </> "test"
- -- print searchDirectories
- -- files <- collectFileMap (testDir : searchDirectories)
- -- print files
- classEi <- parseClassFile (testDir </> "work_queue.e")
+
+getDomain file = do
+ classEi <- parseClassFile file
case classEi of
- Left e -> print e
+ Left err -> error $ "getDomain: " ++ show err
Right cls -> do
- classInts <- Map.elems `fmap` readAllSummaries -- depGenInt files (className cls)
- putStrLn "Generated dependencies"
- -- let unliked = rights (map (unlikeInterfaceM classInts) classInts)
- let domainInts = either (error . show) id $ depGen (makeEnv classInts) "work_queue"
- print (map className domainInts)
- case clasM classInts cls of
- Left e -> print e
- Right typedClass -> typeInterfaces domainInts >>= \ typedDomain ->
- case typedDomain of
- Left err -> print err
- Right typedInts ->
- print (PP.toDoc $ untype $
- instrument (makeEnv typedInts) "dequeue" typedClass)
+ classInts <- Map.elems `fmap` readAllSummaries
+ case depGen (makeEnv classInts) "work_queue" of
+ Left err -> error $ "getDomain: " ++ show err
+ Right domainInts ->
+ case clasM classInts cls of
+ Left err -> error $ "getDomain: " ++ err
+ Right tCls -> do
+ tis <- typeInterfaces domainInts
+ return (tis, tCls)
+
+
+getDomainFile file = do
+ classEi <- parseClassFile file
+ case classEi of
+ Left err -> error $ "getDomain: " ++ show err
+ Right cls -> do
+ classInts <- Map.elems `fmap` readAllSummaries
+ domainInts <- readDomain
+ case clasM classInts cls of
+ Left err -> error $ "getDomain: " ++ err
+ Right tCls -> return (domainInts, tCls)
+
+readDomain :: IO ([AbsClas EmptyBody T.TExpr])
+readDomain = decode <$> BS.readFile "typed_domain.tdom"
+writeDomain file = do
+ (Right tis, _) <- getDomain file
+ BS.writeFile "typed_domain.tdom" $ encode tis
+
+main :: IO ()
+main = do
+ currDir <- getCurrentDirectory
+ let testFile = currDir </> "test" </> "work_queue.e"
+ (typedDomain, typedClass) <- getDomainFile testFile
+ print (PP.toDoc $ untype $
+ instrument (makeEnv typedDomain) "dequeue" typedClass)
instrument :: TInterEnv -> String -> AbsClas (RoutineBody TExpr) TExpr
-> AbsClas (RoutineBody TExpr) TExpr
@@ -68,7 +94,7 @@ instrumentBody :: TInterEnv -> Contract TExpr
-> RoutineBody TExpr -> RoutineBody TExpr
instrumentBody env ens (RoutineBody locals localProc body) =
let
- ensD = map (teToD . clauseExpr) (contractClauses ens)
+ ensD = map (teToDCurr . clauseExpr) (contractClauses ens)
body' = snd $ stmt env [] ensD body
in RoutineBody locals localProc body'
instrumentBody _ _ r = r
@@ -94,7 +120,7 @@ block (cs, s) = (cs, Block s)
replaceClause :: [D.Expr] -> TExpr -> TExpr -> [D.Expr]
replaceClause clauses old new =
- map (replaceExpr (teToD old) (teToD new)) clauses
+ map (replaceExpr (teToDCurr old) (teToDCurr new)) clauses
replaceExpr :: D.Expr -> D.Expr -> D.Expr -> D.Expr
replaceExpr new old = go
@@ -111,7 +137,7 @@ dNeqNull :: Pos UnPosTExpr -> D.Expr
dNeqNull e =
let ClassType cn _ = texprTyp (contents e)
structType = D.StructType cn []
- in D.BinOpExpr (D.RelOp D.Neq structType) (teToD e) D.LitNull
+ in D.BinOpExpr (D.RelOp D.Neq structType) (teToDCurr e) D.LitNull
dConj :: [D.Expr] -> D.Expr
dConj = foldr1 (D.BinOpExpr D.And)
@@ -123,15 +149,30 @@ texprClassName e =
texprInterface :: TInterEnv -> TExpr -> AbsClas EmptyBody T.TExpr
texprInterface env e =
- fromMaybe (error $ "texprInterface: " ++ show e)
+ fromMaybe (error $ "texprInterface: " ++ show e ++ "," ++ show (envKeys env))
(envLookup (texprClassName e) env)
+flatten' :: TInterEnv -> Typ -> AbsClas EmptyBody T.TExpr
+flatten' (ClassEnv e) typ =
+ case idErrorRead (flatten typ) (mkCtx typ (Map.elems e)) of
+ Left e -> error $ "flatten': " ++ e
+ Right c -> classMapExprs updRoutine id id c
+ where
+ updRoutine r = r { routineReq = updContract (routineReq r)
+ , routineEns = updContract (routineEns r)
+ }
+ updContract = mapContract (\cl -> cl {clauseExpr = go' (clauseExpr cl)})
+
+ go' e = attachPos (position e) (go $ contents e)
+ go (T.Call trg n args t) = T.Call (go' trg) n (map go' args) t
+ go (T.CurrentVar t) = T.CurrentVar typ
+
texprPre :: TInterEnv -> TExpr -> String -> [T.TExpr]
texprPre env targ name =
- let iface = texprInterface env targ
- in case findFeature iface name of
- Just rout -> map clauseExpr (contractClauses (routineReq rout))
- Nothing -> error $ "texprPre: can't find routine"
+ let iface = flatten' env (texpr targ)
+ in case findFeatureEx iface name of
+ Just feat -> map clauseExpr (featurePre feat)
+ Nothing -> error $ "texprPre: can't find feature: " ++ show targ ++ "." ++ name
preCond :: TInterEnv -> TExpr -> [D.Expr]
preCond env ex = go (contents ex)
@@ -139,7 +180,7 @@ preCond env ex = go (contents ex)
go' = go . contents
go (T.Call trg name args _) =
let callPreTExpr = texprPre env trg name
- callPres = map teToD callPreTExpr
+ callPres = map (teToD (teToDCurr trg)) callPreTExpr
in dNeqNull trg : concatMap go' (trg : args) ++ callPres
go (T.Access trg _ _) = dNeqNull trg : go' trg
go (T.Old e) = go' e
@@ -225,3 +266,26 @@ stmt' env decls ens = go
(fromCls, from') = stmt env decls bodyCls from
in meldCall decls fromCls (Loop from' untl inv body' var)
go e = error ("stmt'go: " ++ show e)
+
+
+data Indicator = Indicator Typ String deriving (Eq, Ord)
+data Action = Action Typ String deriving (Eq, Ord)
+
+
+domActions :: TInterEnv -> T.TExpr -> Set Action
+domActions env e =
+ let pairs = typeCallPairs e
+ cls = texprInterface env e
+ post = undefined
+ -- Desired interface:
+ domActions' :: TInterEnv -> Set Indicator -> Set Action
+ domActions' = undefined
+ in error "domActions"
+
+typeCallPairs :: T.TExpr -> Set Indicator
+typeCallPairs = go'
+ where go' = go . contents
+ go (T.Call trg name args t) =
+ let argPairs = Set.unions (map typeCallPairs (trg : args))
+ in Set.insert (Indicator (texpr trg) name) argPairs
+ go _ = Set.empty
Please sign in to comment.
Something went wrong with that request. Please try again.