diff --git a/paragon.cabal b/paragon.cabal --- a/paragon.cabal +++ b/paragon.cabal @@ -1,5 +1,5 @@ Name: paragon -Version: 0.1.5 +Version: 0.1.6 License: BSD3 License-File: LICENSE Author: Niklas Broberg @@ -49,7 +49,9 @@ Language.Java.Paragon.TypeCheck.Types, Language.Java.Paragon.TypeCheck.Uniq, Language.Java.Paragon.QuasiQuoter, - Language.Java.Paragon.Compile + Language.Java.Paragon.Compile, + Language.Java.Paragon.PiGeneration, + Language.Java.Paragon.Verbosity Hs-source-dirs: src @@ -80,7 +82,10 @@ Language.Java.Paragon.TypeCheck.Types, Language.Java.Paragon.TypeCheck.Uniq, Language.Java.Paragon.QuasiQuoter, - Language.Java.Paragon.Compile + Language.Java.Paragon.Compile, + Language.Java.Paragon.PiGeneration, + Language.Java.Paragon.Verbosity + Build-Tools: alex >= 2.3 Build-Depends: array >= 0.1, pretty >= 1.0, cpphs >= 1.3, parsec >= 2.1 && < 3, containers >= 0.4 && < 0.5, uniplate == 1.6, directory, filepath, haskell-src-meta, th-lift, template-haskell 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 @@ -25,34 +25,38 @@ main :: IO () main = do (flags, files) <- compilerOpts =<< getArgs - when (Version `elem` flags) $ putStrLn versionString mapM_ setVerbosity $ [ k | Verbose k <- flags ] + when (Version `elem` flags) $ normalPrint versionString + when (Help `elem` flags) $ normalPrint $ usageInfo usageHeader options when (not (null files)) $ compile flags (head files) -- TODO: Enable multiple files --- This probably needs to live somewhere else -data Flag = Verbose Int | Version +data Flag = Verbose Int | Version | Help deriving (Show, Eq) -versionString :: String +versionString, usageHeader :: String versionString = "Paragon Compiler version: 0.1.5" +usageHeader = "Usage: parac [OPTION...] files..." options :: [OptDescr Flag] options = [ Option ['v'] ["verbose"] (OptArg (Verbose . maybe 3 read) "n") "Control verbosity (n is 0--4, normal verbosity level is 1, -v alone is equivalent to -v3" - , Option ['V','?'] ["version"] + , Option ['V'] ["version"] (NoArg Version) "Show version number" + , Option ['h','?'] ["help"] + (NoArg Help) "Show this help" ] compilerOpts :: [String] -> IO ([Flag], [String]) compilerOpts argv = case getOpt RequireOrder options argv of (o,n,[]) -> return (o,n) - (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) - where header = "Usage: parac [OPTION...] files..." + (_,_,errs) -> ioError (userError (concat errs ++ usageInfo usageHeader options)) + + ------------------------------------------------------------------------------------- --type ErrM = Either String @@ -61,20 +65,16 @@ Right a -> return a Left e -> fail $ show e -debugPrint :: String -> IO () -debugPrint = putStrLn ---debugPrint = return () - compile :: [Flag] -> String -> IO () compile flags filePath = do let (directory,fileName) = splitFileName filePath --relative or absolute path? fc <- readFile filePath ast <- liftE $ parser compilationUnit fc - verbosePrint 2 "Parsing complete!" + extraPrint "Parsing complete!" ast2 <- typeCheck directory ast - verbosePrint 2 "Type checking complete!" + extraPrint "Type checking complete!" genFiles filePath ast2 - verbosePrint 2 "File generation complete!" + extraPrint "File generation complete!" genFiles :: FilePath -> CompilationUnit -> IO () genFiles filePath ast = let astC = compileTransform ast diff --git a/src/Language/Java/Paragon/Compile.hs b/src/Language/Java/Paragon/Compile.hs --- a/src/Language/Java/Paragon/Compile.hs +++ b/src/Language/Java/Paragon/Compile.hs @@ -148,52 +148,3 @@ removeParagonTypeArguments (a@(ActualArg (ActualType {})) : as) = a : removeParagonTypeArguments as removeParagonTypeArguments (ActualArg _ : as) = removeParagonTypeArguments as removeParagonTypeArguments (a:as) = a : removeParagonTypeArguments as - -{-- not supported -translateConstructorTypeArguments :: TypeMap -> ExplConstrInv -> ExplConstrInv -translateConstructorTypeArguments env (ThisInvoke targs args) - = ThisInvoke (translateTypeArguments undefined targs) args -translateConstructorTypeArguments env (SuperInvoke targs args) - = SuperInvoke (translateTypeArguments undefined targs) args -translateConstructorTypeArguments env (PrimarySuperInvoke e targs args) - =PrimarySuperInvoke e (translateTypeArguments undefined targs) args -translateConstructorTypeArguments _ x = x --} - -{-- some are not supported -translateMethodCallTypeArguments :: TypeMap -> MethodInvocation -> MethodInvocation ---translateMethodCallTypeArguments env (PrimaryMethodCall e tnargs iden args)=(PrimaryMethodCall e (translateTypeArguments undefined tnargs) iden args) ---translateMethodCallTypeArguments env (SuperMethodCall tnargs iden args) =(SuperMethodCall (translateTypeArguments undefined tnargs) iden args) ---translateMethodCallTypeArguments env (ClassMethodCall n tnargs iden args) =(ClassMethodCall n (translateTypeArguments undefined tnargs) iden args) -translateMethodCallTypeArguments env (TypeMethodCall n tnargs iden args) - = {-let nameOfType (ClassType iargs) = Name $ map fst iargs - (_,tm) = lookupNamed types (nameOfType ctype) env - (tps, cti) = Map.lookup pTys (constrs tm) - in -} TypeMethodCall n (translateTypeArguments undefined tnargs) iden args -translateMethodCallTypeArguments env x = x ---- -translateInstanceTypeArguments :: TypeMap -> Exp -> Exp -translateInstanceTypeArguments env (InstanceCreation targs ctype args mb) - = let pTys = [ fromSrcType env t | FormalParam _ms t _ <- args ] - nameOfType (ClassType iargs) = Name $ map fst iargs - (_,tm) = lookupNamed types (nameOfType ctype) env - (tps, cti) = Map.lookup pTys (constrs tm) - in InstanceCreation (translateTypeArguments tps targs) ctype args mb ---translateInstanceTypeArguments env (QualInstanceCreation e targs iden args mb) --- = QualInstanceCreation e (translateTypeArguments undefined targs) iden args mb -translateInstanceTypeArguments _ x = x ---- -translateParagonTypeArguments :: TypeMap -> ClassType -> ClassType -translateParagonTypeArguments env (ClassType iargs) = - let (is, as) = unzip iargs in - case lookupNamed types (Name is) env of - Just (tps,tm) -> let args = map (translateTypeArguments tps) as - in ClassType $ zip is args -translateParagonTypeArguments _ x = x - --- length of parameter1 and 2 should be the same - --} - - - diff --git a/src/Language/Java/Paragon/PiGeneration.hs b/src/Language/Java/Paragon/PiGeneration.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/Paragon/PiGeneration.hs @@ -0,0 +1,53 @@ +{-# 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/Verbosity.hs b/src/Language/Java/Paragon/Verbosity.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/Paragon/Verbosity.hs @@ -0,0 +1,29 @@ +module Language.Java.Paragon.Verbosity + (setVerbosity, getVerbosity, verbosePrint, + normalPrint, extraPrint, detailPrint, finePrint + ) where + +import Data.IORef +import Control.Monad +import System.IO.Unsafe (unsafePerformIO) -- Trust me, I know what I'm doing... + +{-# NOINLINE unsafeVerbosityGlobalVar #-} +unsafeVerbosityGlobalVar :: IORef Int +unsafeVerbosityGlobalVar = unsafePerformIO $ newIORef 1 + +getVerbosity :: IO Int +getVerbosity = readIORef unsafeVerbosityGlobalVar + +setVerbosity :: Int -> IO () +setVerbosity k = writeIORef unsafeVerbosityGlobalVar k + +verbosePrint :: Int -> String -> IO () +verbosePrint n str = do + k <- getVerbosity + when (n <= k) $ putStrLn str + +normalPrint, extraPrint, detailPrint, finePrint :: String -> IO () +normalPrint = verbosePrint 1 +extraPrint = verbosePrint 2 +detailPrint = verbosePrint 3 +finePrint = verbosePrint 4