diff --git a/paragon.cabal b/paragon.cabal --- a/paragon.cabal +++ b/paragon.cabal @@ -1,5 +1,5 @@ Name: paragon -Version: 0.1.6 +Version: 0.1.7 License: BSD3 License-File: LICENSE Author: Niklas Broberg @@ -50,7 +50,6 @@ Language.Java.Paragon.TypeCheck.Uniq, Language.Java.Paragon.QuasiQuoter, Language.Java.Paragon.Compile, - Language.Java.Paragon.PiGeneration, Language.Java.Paragon.Verbosity Hs-source-dirs: src @@ -83,7 +82,6 @@ Language.Java.Paragon.TypeCheck.Uniq, Language.Java.Paragon.QuasiQuoter, Language.Java.Paragon.Compile, - Language.Java.Paragon.PiGeneration, Language.Java.Paragon.Verbosity diff --git a/src/Language/Java/Paragon.hs b/src/Language/Java/Paragon.hs --- a/src/Language/Java/Paragon.hs +++ b/src/Language/Java/Paragon.hs @@ -31,7 +31,7 @@ when (not (null files)) $ compile flags (head files) -- TODO: Enable multiple files -data Flag = Verbose Int | Version | Help +data Flag = Verbose Int | Version | Help | PiPath String deriving (Show, Eq) versionString, usageHeader :: String @@ -47,6 +47,9 @@ (NoArg Version) "Show version number" , Option ['h','?'] ["help"] (NoArg Help) "Show this help" + , Option ['p'] ["pipath"] + (ReqArg PiPath "") + "Path to the root directory for Paragon interface (.pi) files (default is . )" ] compilerOpts :: [String] -> IO ([Flag], [String]) @@ -68,10 +71,13 @@ compile :: [Flag] -> String -> IO () compile flags filePath = do let (directory,fileName) = splitFileName filePath --relative or absolute path? + let pDir = case [ dir | PiPath dir <- flags ] of + p:_ -> p + _ -> "." fc <- readFile filePath ast <- liftE $ parser compilationUnit fc extraPrint "Parsing complete!" - ast2 <- typeCheck directory ast + ast2 <- typeCheck directory pDir ast extraPrint "Type checking complete!" genFiles filePath ast2 extraPrint "File generation complete!" diff --git a/src/Language/Java/Paragon/Parser.hs b/src/Language/Java/Paragon/Parser.hs --- a/src/Language/Java/Paragon/Parser.hs +++ b/src/Language/Java/Paragon/Parser.hs @@ -38,6 +38,7 @@ import Language.Java.Paragon.Lexer ( L(..), Token(..), lexer) import Language.Java.Paragon.Syntax +import Language.Java.Paragon.Pretty import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Pos @@ -121,6 +122,7 @@ classOrInterfaceDecl = do ms <- list modifier de <- (do cd <- classDecl + checkConstrs (cd []) return $ \ms -> ClassTypeDecl (cd ms)) <|> (do id <- interfaceDecl return $ \ms -> InterfaceTypeDecl (id ms)) @@ -1296,6 +1298,15 @@ ------------------------------------------------------------ test = "public class Foo { }" + +checkConstrs :: ClassDecl -> P () +checkConstrs (ClassDecl _ i _ _ _ cb) = do + let errs = [ ci | ConstructorDecl _ _ ci _ _ _ <- universeBi cb, ci /= i ] + if null errs then return () + else fail $ "Declaration of class " ++ prettyPrint i + ++ " cannot contain constructor with name " + ++ prettyPrint (head errs) + ----------------------------------------------------- diff --git a/src/Language/Java/Paragon/PiGeneration.hs b/src/Language/Java/Paragon/PiGeneration.hs deleted file mode 100644 --- a/src/Language/Java/Paragon/PiGeneration.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Language.Java.Paragon.PiGeneration where - -import Language.Java.Paragon.Syntax -import Control.Applicative -import Language.Java.Paragon.QuasiQuoter - -piTransform :: CompilationUnit -> CompilationUnit -piTransform = transformCompilationUnit ---for generating Pi there should be a package name --- no imports --- one type for each compilationUnit since the execution is for one class but we can transform without considering that condition -transformCompilationUnit :: CompilationUnit -> CompilationUnit -transformCompilationUnit (CompilationUnit mpDecl _ tdecls) - = CompilationUnit mpDecl [] (transformTypeDecl<$>tdecls) ----------------- -transformTypeDecl :: TypeDecl -> TypeDecl -transformTypeDecl (InterfaceTypeDecl (InterfaceDecl mods iden tparams refts ib)) - = ClassTypeDecl (ClassDecl mods iden tparams Nothing refts (transformInterfaceBody ib)) -- Maybe typeDecl -transformTypeDecl (ClassTypeDecl (ClassDecl mods iden tparams mt refts (ClassBody dcls))) - = ClassTypeDecl (ClassDecl mods iden tparams mt refts (ClassBody $ transformDecl<$>dcls)) ----------------- -transformDecl :: Decl -> Decl -transformDecl (MemberDecl md) = MemberDecl $ transformMemberDecl md ----------------- -transformInterfaceBody :: InterfaceBody -> ClassBody -transformInterfaceBody (InterfaceBody mds) = ClassBody $ (\md->MemberDecl (transformMemberDecl md))<$>mds -------------- -transformMemberDecl :: MemberDecl -> MemberDecl -transformMemberDecl f@(FieldDecl fmods [typeQQ|actor|] vdecs) = f -transformMemberDecl (FieldDecl fmods ft vdecs) = (FieldDecl fmods ft (transformVarDecls vdecs)) -transformMemberDecl m@(MethodDecl mmods mtparams mmaybet mident mformparams mexceptionspecs mb) - | Typemethod `elem` mmods = m - | otherwise = MethodDecl mmods mtparams mmaybet mident mformparams mexceptionspecs (transformMethodBody mb) -transformMemberDecl (ConstructorDecl cmods ctparams cident cformparams cexceptionspecs cb) - = ConstructorDecl cmods ctparams cident cformparams cexceptionspecs (transformConstructorBody cb) -transformMemberDecl x = x --- I assumed the LockDecl and PolicyDecl should not be touch --- Also I didnt write code for inner classes/interfaces ------- -transformVarDecls :: [VarDecl] -> [VarDecl] -transformVarDecls vds = [ VarDecl varDeclId Nothing | (VarDecl varDeclId _) <- vds] -------- -transformMethodBody :: MethodBody -> MethodBody -transformMethodBody = const $MethodBody Nothing -- [methodBodyQQ|{}|] --- maybe we have to add nothing instead of "just emptyMethodBody" -------- -transformConstructorBody :: ConstructorBody -> ConstructorBody -transformConstructorBody (ConstructorBody explConstrInvm bs) = ConstructorBody Nothing [] -- second argument nothing ? - - - - diff --git a/src/Language/Java/Paragon/TypeCheck.hs b/src/Language/Java/Paragon/TypeCheck.hs --- a/src/Language/Java/Paragon/TypeCheck.hs +++ b/src/Language/Java/Paragon/TypeCheck.hs @@ -33,11 +33,11 @@ import Data.Generics.Uniplate.Data (transformBi) -typeCheck :: DirectoryPath -> CompilationUnit -> IO CompilationUnit -typeCheck currentDir ast@(CompilationUnit pkg imps [td]) = do +typeCheck :: DirectoryPath -> DirectoryPath -> CompilationUnit -> IO CompilationUnit +typeCheck currentDir piDir ast@(CompilationUnit pkg imps [td]) = do let (skoTd, skoTy) = skolemTypeDecl td e <- runTcCont skoTy $ do - withEnvFromImps "" "" allImps $ do + withEnvFromImps piDir "" allImps $ do --debug "Import env setup" withEnvFromImp currentDir (tdIdentStr skoTd) thisPackage $ do --debug "TypeMap completed" @@ -111,19 +111,19 @@ withEnvFromImps :: DirectoryPath -> String -> [ImportDecl] -> TcCont r a -> TcCont r a -withEnvFromImps dir thisStr is tcba = do +withEnvFromImps piDir thisStr is tcba = do --debug ("withEnvFromImpsies: " ++ show is) --withEnvFromImps dir thisStr (imp:is) = - withFoldMap (withEnvFromImp dir thisStr) is $ tcba + withFoldMap (withEnvFromImp piDir thisStr) is $ tcba -- withEnvFromImp dir thisStr imp . withEnvFromImps dir thisStr is withEnvFromImp :: DirectoryPath -> String -> ImportDecl -> TcCont r a -> TcCont r a -- import java.*; -withEnvFromImp dir thisStr imp@(ImportDecl False (Name pkgNames) True) tcba = do +withEnvFromImp piDir thisStr imp@(ImportDecl False (Name pkgNames) True) tcba = do --debug $ "Setting up import of: " ++ prettyPrint (Name pkgNames) let relative = pathOf pkgNames - absoluteDir = dir ++ pSep:relative ++ [pSep] + absoluteDir = piDir ++ pSep:relative ++ [pSep] names <- liftIO $ getDirectoryContents absoluteDir let classPathsAndNames = [ (absoluteDir ++ name, takeBaseName name) | name <- names @@ -133,10 +133,10 @@ withEnvFromPkg pkgNames classPathsAndNames $ tcba -- import java.TypeName; -withEnvFromImp dir _ imp@(ImportDecl False (Name clsPkgName) False) tcba = do +withEnvFromImp piDir _ imp@(ImportDecl False (Name clsPkgName) False) tcba = do --debug $ "Setting up single import of: " ++ show clsPkgName let relative = pathOf clsPkgName - absoluteFile = dir ++ pSep:relative ++ ".pi" + absoluteFile = piDir ++ pSep:relative ++ ".pi" (Ident className) = last clsPkgName pkgNames = init clsPkgName withEnvFromSingleClass pkgNames absoluteFile className $ tcba