paragon-0.1.3: src/Language/Java/Paragon.hs
-- 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
-}