-- module Language.Java.Paragon where import Language.Java.Paragon.Syntax import Language.Java.Paragon.Parser import Language.Java.Paragon.Pretty import Language.Java.Paragon.TypeCheck import Language.Java.Paragon.Compile import Language.Java.Paragon.PiGeneration --import Language.Java.Paragon.TypeCheck.TcEnv --import Language.Java.Paragon.TypeCheck.Locks --import Language.Java.Paragon.TypeCheck.Policy --import qualified Language.Java.Paragon.TypeCheck.Types as TP import System.FilePath import System.Environment import System.Directory import Control.Monad import qualified Data.Map as DM import Data.Maybe ------------------------------------------------------------------------------------- main :: IO () main = do [f] <- getArgs compile f ------------------------------------------------------------------------------------- --type ErrM = Either String liftE :: Show e => Either e a -> IO a liftE eea = case eea of Right a -> return a Left e -> fail $ show e debugPrint :: String -> IO () debugPrint = putStrLn --debugPrint = return () compile :: String -> IO () compile filePath = do let (directory,fileName) = splitFileName filePath --relative or absolute path? fc <- readFile filePath ast <- liftE $ parser compilationUnit fc debugPrint "Parsing complete!" ast2 <- typeCheck directory ast debugPrint "Type checking complete!" genFiles filePath ast2 debugPrint "File generation complete!" -- import this from TypeCheck.hs --typeCheck :: CompilationUnit -> IO CompilationUnit --typeCheck = undefined genFiles :: FilePath -> CompilationUnit -> IO () genFiles filePath ast = let astC = compileTransform ast astPi = piTransform ast baseName = takeBaseName filePath directory = takeDirectory filePath javaPath = directory baseName <.> "java" piPath = directory baseName <.> "pi" java,pi :: String java = prettyPrint astC pi = prettyPrint astPi in writeFile javaPath java >> writeFile piPath pi {- compile2 :: String -> IO () compile2 filePath = do fc <- readFile filePath let east = parser compilationUnit fc case east of Left errs -> print errs Right ast -> do print ast --DEBUG let (directory,fileName) = splitFileName filePath --relative or absolute path? ienv <- createIEnv directory ast putStrLn "IEnv created" mds <- checkTMsigs ienv ast let tmsenv = createTMSEnv ienv mds putStrLn "Typemethod sigs added" fds <- checkTFs tmsenv ast let tmenv = createTMEnv tmsenv fds putStrLn "Field and method sigs added" tms <- checkTMs tmenv ast let tenv = createTEnv tmenv tms putStrLn "Typemethod bodies added" memds <- checkSigs tenv ast let env = createEnv tenv memds checkBodies env ast ------------------------------------------------------------------------------------- defaultImportDecls :: [ImportDecl] defaultImportDecls = [ ImportDecl False (Name [Ident "paragon"]) True ,ImportDecl False (Name [Ident "paragon", Ident "util"]) True ,ImportDecl False (Name [Ident "paragon", Ident "io"]) True] ------------------------------------------------------------------------------------- createIEnv :: DirectoryPath -> CompilationUnit -> IO IEnv createIEnv currentDir (CompilationUnit _ imps [td]) = foldM (\env imp -> setIEnvOfImport imp env currentDir) (emptyTM (TP.clsType $ tdIdent td)) imps ------------------------------------------------------------------------------------- ----- import Java.*; setIEnvOfImport :: ImportDecl -> IEnv -> DirectoryPath -> IO IEnv setIEnvOfImport (ImportDecl False (Name idents) True) fileEnv currentDirectory = do let relative = pathOf idents let absoluteDir = currentDirectory ++ [pathSeparator] ++ relative ++ [pathSeparator] names <- getDirectoryContents absoluteDir let classPathsAndName = [ (absoluteDir ++ name, takeBaseName name) | name <- names , takeExtension name == ".pi"] let packageNames = idents foldM (\fileEnv' (classPath,className) -> setIEnvOfCompilationUnit packageNames className fileEnv' classPath) fileEnv classPathsAndName ------------------------------ ----- import Java.typename; setIEnvOfImport (ImportDecl False (Name idents) False) fileEnv currentDirectory = do let relative = pathOf idents let absoluteFile = currentDirectory ++ [pathSeparator] ++ relative ++ ".pi" let (Ident className) = last idents let packageNames = init idents setIEnvOfCompilationUnit packageNames className fileEnv absoluteFile ------------------------------------------------------------------------------------- setIEnvOfCompilationUnit :: [Ident] -> String -> IEnv -> String -> IO IEnv setIEnvOfCompilationUnit [] className env classPath = fetchCompilationUnit className env classPath setIEnvOfCompilationUnit (packageName:packageNames) className env classPath = do let oldNestedTypeMap = case DM.lookup packageName (types env) of Just (_,mp) -> mp _ -> (emptyTM undefined) -- what is "this" of package ?!! newTypeMap <- setIEnvOfCompilationUnit packageNames className oldNestedTypeMap classPath return env{ types= DM.insert packageName ([],newTypeMap) (types env) } ------------------------------------------------------------------------------------- tdIdent :: TypeDecl -> Ident tdIdent (ClassTypeDecl (ClassDecl _ i _ _ _ _)) = i tdIdent (InterfaceTypeDecl (InterfaceDecl _ i _ _ _)) = i ------------------------------------------------------------------------------------- getInterface :: String -> IO InterfaceDecl getInterface piPath = do fc <- readFile piPath let east = parser compilationUnit fc case east of Left errs -> error $ show errs Right (CompilationUnit _ _ [(InterfaceTypeDecl interface)]) -> -- assume there is only one type in each pi file and that is interface return interface _ -> error "\nThere should be only one interface type per Pi file!\n" ------------------------------------------------------------------------------------- getReadPolicy :: [Modifier] -> Policy getReadPolicy mods = [pol |(Reads pol) <- mods ]!!0 -- Read Policy? what if no read policy? ------------------------------------------------------------------------------------- fetchFieldDecls :: [MemberDecl] -> DM.Map Ident (VTypeInfo Exp Policy Lock) fetchFieldDecls memberDecls = foldl (\m1 (FieldDecl fmods ftype fvardecls)-> (foldl (\m2 (VarDecl (VarId fid) _) -> DM.insert fid VTI { varType = (TP.fromSrcType ftype) ,varPol = getReadPolicy fmods ,varStatic = (Static `elem` fmods) ,varFinal = (Final `elem` fmods) } m2 ) m1 fvardecls ) ) (DM.empty) [f|f@(FieldDecl _ _ _) <- memberDecls] ------------------------------------------------------------------------------------- fetchMethodDecls:: [MemberDecl] -> DM.Map (Ident, [TP.TcTypeExp]) (MTypeInfo Exp Policy Lock) fetchMethodDecls memberDecls = foldl (\m (MethodDecl mmods mtparams mmaybet mident mformparams mexceptionspecs _)-> DM.insert (mident,[TP.fromSrcType pType|(FormalParam _ pType _ _)<-mformparams]) MTI { mRetType = if (isNothing mmaybet) then TP.TcVoidT else TP.fromSrcType$ fromJust mmaybet , mRetPol = getReadPolicy mmods , mPars = [getReadPolicy pModifiers |(FormalParam pModifiers pType pBool pVarDeclId) <- mformparams] , mWrites = [p| (Writes p) <-mmods ]!!0 , mExpects = concat [l| (Expects l) <-mmods ] , mLMods = ( concat [l| (Closes l) <-mmods], concat [l|(Opens l)<-mmods]) , mExns = map (\ (ExceptionSpec emods eExceptionType) -> (TP.fromSrcType (RefType eExceptionType), ExnSig { exnReads = getReadPolicy emods ,exnWrites = [p| (Writes p) <-emods ]!!0 ,exnMods = ( concat [l| (Closes l) <-emods], concat [l|(Opens l)<-emods]) })) mexceptionspecs } m ) (DM.empty) [m|m@(MethodDecl mmods _ _ _ _ _ _)<-memberDecls] ------------------------------------------------------------------------------------- fetchConstructorDecls :: [MemberDecl]-> DM.Map [TP.TcTypeExp] (CTypeInfo Exp Policy Lock) fetchConstructorDecls memberDecls = foldl (\m (ConstructorDecl cmods ctparams cident cformparams cexceptionspecs _)-> DM.insert ([TP.fromSrcType pType|(FormalParam _ pType _ _)<-cformparams]) CTI { cPars = [getReadPolicy pModifiers|(FormalParam pModifiers pType pBool pVarDeclId)<-cformparams] ,cWrites = [ p| (Writes p) <-cmods ]!!0 ,cExpects = concat [l| (Expects l) <-cmods ] ,cLMods = (concat [l|(Closes l)<-cmods],concat [l|(Opens l)<-cmods]) ,cExns = map (\ (ExceptionSpec emods eExceptionType) -> ( (TP.fromSrcType (RefType eExceptionType)) ,ExnSig { exnReads = getReadPolicy emods ,exnWrites = [p| (Writes p) <-emods ]!!0 ,exnMods = ( concat [l| (Closes l) <-emods], concat [l|(Opens l)<-emods]) })) cexceptionspecs } m ) (DM.empty) [c|c@(ConstructorDecl _ _ _ _ _ _ )<-memberDecls] ------------------------------------------------------------------------------------- fetchLockDecls :: [MemberDecl] -> DM.Map Ident (LTypeInfo Policy) fetchLockDecls memberDecls = foldl (\m (LockDecl lmods lident lmaybeidents maybelockproperties)-> DM.insert lident LTI { arity = length lmaybeidents ,lockPol = getReadPolicy lmods } m ) (DM.empty) [l|l@(LockDecl _ _ _ _)<-memberDecls] ------------------------------------------------------------------------------------- fetchPolicyDecls :: [MemberDecl] -> DM.Map Ident Policy fetchPolicyDecls memberDecls = foldl (\m (PolicyDecl pmods pident ppolicy)-> DM.insert pident (getReadPolicy pmods) m) (DM.empty) [p|p@(PolicyDecl _ _ _)<-memberDecls] ------------------------------------------------------------------------------------- fetchTypemethods :: [MemberDecl] -> DM.Map Ident ([Ident], Block) fetchTypemethods memberDecls = foldl (\m (MethodDecl tmmods tmtparams tmmaybet tmident tmformparams _ (MethodBody(Just tmblock)) )-> DM.insert tmident ( map (\(FormalParam _ _ _ (VarId vident) ) -> vident) tmformparams ,tmblock) m ) (DM.empty) [tm|tm@(MethodDecl tmmods _ _ _ _ _ _ )<-memberDecls ,Typemethod `elem`tmmods] ------------------------------------------------------------------------------------- fetchActors :: [MemberDecl] -> DM.Map Ident Exp fetchActors memberDecls = foldl (\m (FieldDecl amods _ vardecls)-> (foldl (\m' (VarDecl (VarId aid) init) -> let aexp = case init of Just (InitExp a) -> a Nothing -> newActor in DM.insert aid aexp m' ) m vardecls ) ) (DM.empty) [p|p@(FieldDecl _ (PrimType ActorT) _)<-memberDecls] ------------------------------------------------------------------------------------- fetchCompilationUnit :: String -> IEnv -> String -> IO IEnv fetchCompilationUnit compilationUnitName env piPath = do (InterfaceDecl _ id@(Ident compilationUnitName) params _supers (InterfaceBody memberDecls)) <- getInterface piPath -- Assume there is only one type in each pi file -- with the specified name -- Assume the superclasses dont matter now let newTypeMap= TypeMap { this= error "Non-local use of 'this'." ,fields = fetchFieldDecls memberDecls ,methods = fetchMethodDecls memberDecls ,constrs= fetchConstructorDecls memberDecls ,locks= fetchLockDecls memberDecls ,policies= fetchPolicyDecls memberDecls ,actors= fetchActors memberDecls ,typemethods= fetchTypemethods memberDecls ,types = DM.empty -- inner classes / inner interfaces } return env{ types = (DM.insert id (params,newTypeMap) (types env)) } ------------------------------------------------------------------------------------- newActor :: Exp newActor = ExpName (Name [Ident "$newActor"]) ------------------------------------------------------------------------------------- -- [ d1 , d2 , x ] -> d1/d2/x , x can be folder or file (.class) pathOf :: [Ident] -> String pathOf ((Ident name1):idents) = foldl (\p (Ident str) -> p ++ [pathSeparator] ++ str ) name1 idents ------------------------------------------------------------------------------------- expand :: TypeMap a b c -> Map Ident (Name, TypeMap a b c) expand env = DM.fromList(concat(map (expand' []) (DM.toList(types env)))) expand' :: [Ident] -> (Ident,([TypeParam],TypeMap a b c)) -> [(Ident,(Name, TypeMap a b c))] expand' ns (i,(_,env)) | null $ DM.toList (types env) = [(i ,(Name (ns++[i]),env) )] | True = concat(map (expand' (ns++[i])) (DM.toList(types env))) ------------------------------------------------------------------------------------- type IEnv = TypeMapExp type TMSEnv = TypeMapExp type TMEnv = TypeMapExp type TEnv = TypeMapExp type Env = TypeMapExp type DirectoryPath = String type ClassPath = String ------------------------------------------------------------------------------------- createTMSEnv :: IEnv -> [MemberDecl] -> TMSEnv createTMSEnv = undefined ------------------------------------------------------------------------------------- createTMEnv :: TMSEnv -> [MemberDecl] -> TMEnv createTMEnv = undefined ------------------------------------------------------------------------------------- createTEnv :: TMEnv -> [MemberDecl] -> TEnv createTEnv = undefined ------------------------------------------------------------------------------------- createEnv :: TEnv -> [MemberDecl] -> Env createEnv = undefined ------------------------------------------------------------------------------------- -- Dummies: checkTMsigs = undefined checkTFs = undefined checkTMs = undefined checkSigs = undefined checkBodies = undefined ------------------------------------------------------------------------------------- testImportDecl = ImportDecl False (Name [Ident "paragon",Ident "util"]) True -------------------------------------------------------------------------------------} --assume there is no static imports {- ----- import static Java.typename.member; createIEnv' (ImportDecl True (Name idents) False) ienv currentDirectory = do let relative = pathOf $ init idents let absoluteFile = currentDirectory ++ [pathSeparator] ++ relative ++ ".pi" let (Ident memberName) = last idents let (Ident className) = last $ init idents fetchStaticMember memberName className ienv absoluteFile ----- import static Java.typename.*; createIEnv' (ImportDecl True (Name idents) True) ienv currentDirectory = do let relative = pathOf idents let absoluteFile = currentDirectory ++ [pathSeparator] ++ relative ++ ".pi" let (Ident className) = last idents fetchStaticCompilationUnit className ienv absoluteFile -} -- Assume we don't have any static import {- -- import package1.class1.member1 fetchStaticCompilationUnit :: String -> IEnv -> String -> IO IEnv fetchStaticCompilationUnit compilationUnitName env piPath = do (InterfaceDecl mods id@(Ident compilationUnitName) params refs body) <- getInterface piPath -- Assume there is only one type in each pi file -- with the specified name let mp = types env let newTypeMap= TypeMap { this= undefined ,fields = undefined ,methods = undefined ,constrs= (DM.empty) ,locks=undefined ,policies=undefined ,typemethods=undefined ,types = (DM.empty) } return env{ types = (DM.insert (Name [id]) newTypeMap mp) } --error here because the idnet is not a name fetchStaticMember :: String -> String -> IEnv -> String -> IO IEnv fetchStaticMember memberName compilationUnitName env piPath = do (InterfaceDecl mods id@(Ident compilationUnitName) params refs body) <- getInterface piPath -- Assume there is only one type in each pi file -- with the specified name let mp = types env let newTypeMap= TypeMap { this= undefined ,fields = undefined ,methods = undefined ,constrs=undefined ,locks=undefined ,policies=undefined ,typemethods=undefined ,types = (DM.empty) } return env{ types = (DM.insert (Name [id]) newTypeMap mp) } --error here because the idnet is not a name -}