packages feed

paragon 0.1.5 → 0.1.6

raw patch · 5 files changed

+104/−66 lines, 5 files

Files

paragon.cabal view
@@ -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
src/Language/Java/Paragon.hs view
@@ -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
src/Language/Java/Paragon/Compile.hs view
@@ -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---}---
+ src/Language/Java/Paragon/PiGeneration.hs view
@@ -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 ?++++
+ src/Language/Java/Paragon/Verbosity.hs view
@@ -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