diff --git a/dist/build/j2hs/j2hs-tmp/Translate.hs b/dist/build/j2hs/j2hs-tmp/Translate.hs new file mode 100644 --- /dev/null +++ b/dist/build/j2hs/j2hs-tmp/Translate.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE Haskell2010 #-} +{-# OPTIONS -Wall #-} + +module Translate where + +import Typomatic +import Utils + +import Foreign.Java.Utils +import Data.Map (Map) + +import Language.Haskell.Reflect +import Language.Java.Reflect +import qualified Language.Java.Reflect.Types as Types + +import Data.Function + +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Map as Map + +import qualified Haskell.X as X + +import Control.Arrow + + +checkedLookup info name = maybe fail id (Map.lookup name info) + where fail = error ((\_ -> let { __ = +{-# LINE 29 "Translate.hss" #-} +concat ["class definition for '", (name), "' not found."] +{-# LINE 29 "Translate.hss" #-} +} in __) undefined) + + + +pkgModExports :: ClassInfo -> [JavaClass] -> String +pkgModExports info classes = concatMap (\(t, b) -> ((\_ -> let { __ = +{-# LINE 34 "Translate.hss" #-} +concat [" -- * ", (show t), "s\n", (b), ""] +{-# LINE 34 "Translate.hss" #-} +} in __) undefined)) + $ map (second $ concatMap format) + $ X.aggregateAL + $ zip (map classType classes) classes + where + format clazz = + let modName = (classModName info . className) clazz + haskName = takeClassName $ modName + javaName = takeClassName $ className clazz + dataDecl = if classIface clazz then "" else + ((\_ -> let { __ = +{-# LINE 44 "Translate.hss" #-} +concat [" ", (dataTName haskName), " (..),\n"] +{-# LINE 44 "Translate.hss" #-} +} in __) undefined) + in ((\_ -> let { __ = +{-# LINE 45 "Translate.hss" #-} +concat [" -- ** ", (show $ classType clazz), " ", (javaName), "\n -- | For constructors, methods, and so on, see: \"", (modName), "\".\n ", (tyclTName haskName), ",\n", (dataDecl), " ", (newtTName haskName), " ", (if classEnum clazz then "(..)" else ""), ",\n"] +{-# LINE 51 "Translate.hss" #-} +} in __) undefined) + + +pkgModImports :: ClassInfo -> [JavaClass] -> String +pkgModImports info classes = concatMap (format . getModName) classes + where + format modName = ((\_ -> let { __ = +{-# LINE 57 "Translate.hss" #-} +concat ["import ", (modName), "__ hiding (info')\n"] +{-# LINE 57 "Translate.hss" #-} +} in __) undefined) + getModName = (classModName info . className) + + +pkgModDecl :: ClassInfo -> [JavaClass] -> String +pkgModDecl info classes = "" + + +classModImports :: ClassInfo -> JavaClass -> String +classModImports info clazz = concatMap format references + where + format package = ((\_ -> let { __ = +{-# LINE 68 "Translate.hss" #-} +concat ["import qualified ", (package), "\n"] +{-# LINE 68 "Translate.hss" #-} +} in __) undefined) + references = Set.toList + $ Set.map (fst . splitClassName . getModName . checkedLookup info) + $ Set.fromList (className clazz : dependencies) + dependencies = classDependencies clazz + getModName = (classModName info . className) + + +classModExports :: ClassInfo -> JavaClass -> String +classModExports info clazz = " -- * Methods\n" ++ concatMap methodExport methodNames + where + methods = List.sortBy (compare `on` methodName) (classMethods clazz) + methodNames = mkMethodNames methods + methodExport name = name ++ ", \n" + + +classModDecl :: ClassInfo -> JavaClass -> String +classModDecl info clazz = concatMap methodDecl $ zip methodNames methods + where + methods = List.sortBy (compare `on` methodName) (classMethods clazz) + methodNames = mkMethodNames methods + methodDecl (name, method) + | arrayTypes = ((\_ -> let { __ = +{-# LINE 90 "Translate.hss" #-} +concat ["", (name), " :: ", (signature), "\n", (name), " = Prelude.undefined\n"] +{-# LINE 93 "Translate.hss" #-} +} in __) undefined) + | otherwise = ((\_ -> let { __ = +{-# LINE 94 "Translate.hss" #-} +concat ["", (haddock), "\n", (name), " :: ", (signature), "\n", (name), "", (argsDecl), " = do\n (Prelude.Just clazz) <- JNI.getClass \"", (className clazz), "\"\n (Prelude.Just method) <- clazz `JNI.", (getMethod), "` ", (jniSignature), "\n", (thisArg), "", (readArgs), " result <- JNI.", (callMethod), " method ", (argsRefs), "\n ", (convertResult), " result\n"] +{-# LINE 104 "Translate.hss" #-} +} in __) undefined) + where + arrayTypes +-- | any isArrayType (methodParams method) = True + | (Just ret) <- fst (methodReturnType method) = isArrayType ret + | otherwise = False + isArrayType x = case x of JArr _ -> True ; _ -> False + isStatic = methodStatic method + javaSignature = fJavaSignature argsInfo + javaReturnType = fJavaReturnType argsInfo + jniSignature = fJniSignature argsInfo + signature = fSignature argsInfo + getMethod = if isStatic then "getStaticMethod" else "getMethod" + callMethod = if isStatic then "callStaticMethodE" else "callMethodE" + args = fArgNames argsInfo + argsNotThis = (if isStatic then id else tail) args + argsInfo = runTypomatic info (typomatic clazz method) + argsDecl = concatMap (' ':) args + argsRefs = concatMap (++ "' ") args + haddock = ((\_ -> let { __ = +{-# LINE 123 "Translate.hss" #-} +concat ["-- | @", (if isStatic then "static " else "virtual "), "", (if methodSynchronized method then "synchronized " else ""), "", (if methodNative method then "native " else ""), "", (if methodFinal method then "final " else ""), "", (javaSignature), " -> ", (javaReturnType), "@"] +{-# LINE 128 "Translate.hss" #-} +} in __) undefined) + thisArg = if isStatic then "" else ((\_ -> let { __ = +{-# LINE 129 "Translate.hss" #-} +concat [" ", (head args), "' <- JNI.asObject ", (head args), "\n"] +{-# LINE 129 "Translate.hss" #-} +} in __) undefined) + readArgs = concatMap ((" " ++). uncurry readArg) (zip argsNotThis (map fst $ methodParams method)) + readArg name jtype = case jtype of + JBoolean -> ((\_ -> let { __ = +{-# LINE 132 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toBoolean ", (name), "\n"] +{-# LINE 132 "Translate.hss" #-} +} in __) undefined) + JChar -> ((\_ -> let { __ = +{-# LINE 133 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toChar ", (name), "\n"] +{-# LINE 133 "Translate.hss" #-} +} in __) undefined) + JByte -> ((\_ -> let { __ = +{-# LINE 134 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toByte ", (name), "\n"] +{-# LINE 134 "Translate.hss" #-} +} in __) undefined) + JShort -> ((\_ -> let { __ = +{-# LINE 135 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toShort ", (name), "\n"] +{-# LINE 135 "Translate.hss" #-} +} in __) undefined) + JInt -> ((\_ -> let { __ = +{-# LINE 136 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toInt ", (name), "\n"] +{-# LINE 136 "Translate.hss" #-} +} in __) undefined) + JLong -> ((\_ -> let { __ = +{-# LINE 137 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toLong ", (name), "\n"] +{-# LINE 137 "Translate.hss" #-} +} in __) undefined) + JFloat -> ((\_ -> let { __ = +{-# LINE 138 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toFloat ", (name), "\n"] +{-# LINE 138 "Translate.hss" #-} +} in __) undefined) + JDouble -> ((\_ -> let { __ = +{-# LINE 139 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.toDouble ", (name), "\n"] +{-# LINE 139 "Translate.hss" #-} +} in __) undefined) + JObj _ -> ((\_ -> let { __ = +{-# LINE 140 "Translate.hss" #-} +concat ["", (name), "' <- Prelude.Just <$> JNI.asObject ", (name), "\n"] +{-# LINE 140 "Translate.hss" #-} +} in __) undefined) + JArr _ -> ((\_ -> let { __ = +{-# LINE 141 "Translate.hss" #-} +concat ["", (name), "' <- JNIS.asMaybeArrayObject ", (name), "\n"] +{-# LINE 141 "Translate.hss" #-} +} in __) undefined) + convertResult = ("JNIS." ++) $ case fst (methodReturnType method) of + Nothing -> "toVoidResult" + Just t -> case t of + JBoolean -> "toBooleanResult" + JChar -> "toCharResult" + JByte -> "toByteResult" + JShort -> "toShortResult" + JInt -> "toIntResult" + JLong -> "toLongResult" + JFloat -> "toFloatResult" + JDouble -> "toDoubleResult" + JObj n -> "toObjectResult" + JArr c -> "toArrayResult" + + + +mkMethodNames :: [JavaMethod] -> [String] +mkMethodNames = concatMap (zipWith (flip (++)) (iterate (++"'") "")) + . List.group . map sanitize . map methodName + where + sanitize name + | Char.isUpper (head name) = '_' : name + | name `elem` haskellKeywords = name ++ "'" + | otherwise = name + + +-- Hidden Modules and Boot files + + +classModExports' :: ClassInfo -> JavaClass -> String +classModExports' info clazz = ((\_ -> let { __ = +{-# LINE 172 "Translate.hss" #-} +concat [" ", (tyclTName haskName), ",\n ", (dataTName haskName), " (..),\n ", (newtTName haskName), " ", (if classEnum clazz then "(..)" else ""), ",\n"] +{-# LINE 176 "Translate.hss" #-} +} in __) undefined) + where + haskName = takeClassName $ classModName clazz + javaName = takeClassName $ className clazz + + +classBootExports' :: ClassInfo -> JavaClass -> String +classBootExports' info clazz = ((\_ -> let { __ = +{-# LINE 183 "Translate.hss" #-} +concat [" ", (tyclTName haskName), ",\n ", (dataTName haskName), " (..),\n ", (newtTName haskName), ",\n"] +{-# LINE 187 "Translate.hss" #-} +} in __) undefined) + where + haskName = takeClassName $ classModName clazz + javaName = takeClassName $ className clazz + + +classBootImports' :: ClassInfo -> JavaClass -> String +classBootImports' info clazz + = concatMap (format . classModName) supertypes + where + format modName = ((\_ -> let { __ = +{-# LINE 197 "Translate.hss" #-} +concat ["import qualified ", (modName), "__\n"] +{-# LINE 197 "Translate.hss" #-} +} in __) undefined) + supertypes = map (checkedLookup info) + $ Set.toList + $ Set.fromList (classParents clazz ++ classIfaces clazz) + + +classModImports' :: ClassInfo -> JavaClass -> String +classModImports' info clazz = "" + + +classBootDecl' :: ClassInfo -> JavaClass -> String +classBootDecl' info clazz + | classEnum clazz = ((\_ -> let { __ = +{-# LINE 209 "Translate.hss" #-} +concat ["class ", (tyclTDecl), "\ndata ", (newtTDecl), " = ", (enumConstants), "\ndata ", (dataTDecl), " = ", (dataCDecl), "\n"] +{-# LINE 213 "Translate.hss" #-} +} in __) undefined) + | otherwise = ((\_ -> let { __ = +{-# LINE 214 "Translate.hss" #-} +concat ["class ", (tyclTDecl), "\nnewtype ", (newtTDecl), " = ", (newtCDecl), " JNI.JObject\ndata ", (dataTDecl), " = ", (dataCDecl), "\n"] +{-# LINE 218 "Translate.hss" #-} +} in __) undefined) + where baseName = takeClassName $ classModName clazz + params = concatMap (\(p:ps) -> ' ' : Char.toLower p : ps) + $ map (tyVarName . paramName) $ classTypeParams clazz + newtTDecl = newtTName baseName ++ params + newtCDecl = newtCName baseName + dataTDecl = dataTName baseName ++ params + dataCDecl = dataCName baseName ++ params + tyclTDecl = ((\_ -> let { __ = +{-# LINE 226 "Translate.hss" #-} +concat ["(JNI.JavaObject this", (context), ") => ", (tyclTName baseName), " this"] +{-# LINE 226 "Translate.hss" #-} +} in __) undefined) + context = concatMap parentContext (classParents clazz) + parentContext parent = ((\_ -> let { __ = +{-# LINE 228 "Translate.hss" #-} +concat [", ", (qualifiedName), " this"] +{-# LINE 228 "Translate.hss" #-} +} in __) undefined) + where parentClass = info Map.! parent + modName = classModName parentClass + qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName) + enumConstants = concat $ List.intersperse " | " $ map sanitize $ map snd $ classEnumConstants clazz + where sanitize (x:xs) = Char.toUpper x : xs + + +classModDecl' :: ClassInfo -> JavaClass -> String +classModDecl' info clazz + | classEnum clazz = ((\_ -> let { __ = +{-# LINE 238 "Translate.hss" #-} +concat ["instance JNI.JavaObject (", (newtTDecl), ") where\n asObject = Prelude.undefined\ninstance ", (tyclTName baseName), " (", (newtTDecl), ")\ninstance JNIS.InstanceOf (", (dataTDecl), ") where\n type CoercedType (", (dataTDecl), ") = (", (newtTDecl), ")\n", (instances), "\n"] +{-# LINE 245 "Translate.hss" #-} +} in __) undefined) + | otherwise = ((\_ -> let { __ = +{-# LINE 246 "Translate.hss" #-} +concat ["instance JNI.JavaObject (", (newtTDecl), ") where\n asObject (", (newtCName baseName), " obj) = return obj\ninstance JNIS.UnsafeCast (", (newtTDecl), ") where\n unsafeFromJObject obj = return (", (newtCDecl), " obj)\ninstance ", (tyclTName baseName), " (", (newtTDecl), ")\ninstance JNIS.InstanceOf (", (dataTDecl), ") where\n type CoercedType (", (dataTDecl), ") = (", (newtTDecl), ")\n coerce o t = do\n obj <- JNI.asObject o\n (Prelude.Just clazz) <- JNI.getClass \"", (fullClassName), "\"\n isInstanceOf <- obj `JNI.isInstanceOf` clazz\n if isInstanceOf\n then Prelude.Just <$> (JNIS.unsafeFromJObject obj)\n else return Prelude.Nothing\n", (instances), "\n"] +{-# LINE 262 "Translate.hss" #-} +} in __) undefined) + where fullClassName = className clazz + baseName = takeClassName $ classModName clazz + params = concatMap (\(p:ps) -> ' ' : Char.toLower p : ps) + $ map (tyVarName . paramName) $ classTypeParams clazz + newtTDecl = newtTName baseName ++ params + newtCDecl = newtCName baseName + dataTDecl = dataTName baseName ++ params + dataCDecl = dataCName baseName ++ params + instances = concatMap parentInstance (classParents clazz) + parentInstance parent = ((\_ -> let { __ = +{-# LINE 272 "Translate.hss" #-} +concat ["instance ", (qualifiedName), " (", (newtTDecl), ")\n"] +{-# LINE 274 "Translate.hss" #-} +} in __) undefined) + where parentClass = info Map.! parent + modName = classModName parentClass + qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName) + + diff --git a/j2hs.cabal b/j2hs.cabal --- a/j2hs.cabal +++ b/j2hs.cabal @@ -1,5 +1,5 @@ name: j2hs -version: 0.99 +version: 0.99.1 license: MIT license-file: LICENSE @@ -23,14 +23,16 @@ hs-source-dirs: src main-is: Main.hs - other-modules: Options - , Types - , Java2Haskell + other-modules: Java2Haskell , JavaSE6 - , Segments , CodeGen.Typomatic , CodeGen.Class , CodeGen.JavaBindings + , MultiMap + , Options + , Segments + , Translate + , Types , Utils build-depends: base >= 4.5 && < 5 diff --git a/src/MultiMap.hs b/src/MultiMap.hs new file mode 100644 --- /dev/null +++ b/src/MultiMap.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE Haskell2010 + , DeriveDataTypeable + #-} +{-# OPTIONS + -Wall + -fno-warn-name-shadowing + #-} + +-- | +-- A very simple MultiMap, based on 'Data.Map.Map' from the containers package. +module MultiMap ( + + -- * MultiMap type + MultiMap, + + -- * Query + null, + size, + numKeys, + numValues, + + member, + notMember, + lookup, + + -- * Operators + (!), + + -- * Construction + empty, + + -- ** Insertion + insert, + + -- ** Delete + delete, + + -- * Traversal + map, + mapKeys, + mapWithKey, + + -- * Folds + foldr, + foldl, + foldrWithKey, + foldlWithKey, + + -- * Conversion + elems, + keys, + keysSet, + assocs, + + toMap, + toMapOfSets, + toList, + fromList, + fromMap, + + -- * Min/Max + findMin, + findMax, + findMinWithValues, + findMaxWithValues + + ) where + +import Prelude hiding (lookup, map, null, foldr, foldl) +import qualified Prelude as P + +import qualified Data.Set as Set +import Data.Set (Set) + +import qualified Data.Map as Map +import Data.Map (Map) + +import Data.Word +import Data.Data + + +-- | A MultiMap with keys @k@ and values @v@. +-- +-- A key can have multiple values (but not zero). +-- The same value can be added multiple times (thus no +-- constraints are ever imposed on @v@). +-- +-- Internally this is simply a @Map k [v]@. +-- See 'toMap' for accessing the underlying 'Map'. +newtype MultiMap k v = MultiMap (Word32, Word32, Map k [v]) + deriving (Data, Typeable) + + +null :: MultiMap k a -> Bool +-- ^ /O(1)./ Check whether the multimap is empty or not. +null (MultiMap (_, _, m)) = Map.null m + + +size :: MultiMap k a -> Int +-- ^ /O(1)./ The number of elements in the multimap. +size (MultiMap (_, size, _)) = fromIntegral size + + +numKeys :: MultiMap k a -> Word32 +-- ^ /O(1)./ The number of keys in the multimap. +-- +-- As this is a multimap, the number of keys is not +-- necessarily equal to the number of values. +numKeys (MultiMap (nk, _, _)) = nk + + +numValues :: MultiMap k a -> Word32 +-- ^ /O(1)./ The number of values in the multimap. +-- +-- As this is a multimap, the number of keys is not +-- necessarily equal to the number of values. +numValues (MultiMap (_, nv, _)) = nv + + +notMember, member :: Ord k => MultiMap k a -> k -> Bool +-- | /O(log n)./ Is the key a member of the multimap? +member (MultiMap (_, _, map)) key = Map.member key map +-- | /O(log n)./ Is the key not a member of the multimap? +notMember key = not . member key + + +(!) :: Ord k => MultiMap k a -> k -> [a] +-- ^ As @flip lookup@ +(!) = flip lookup + + +lookup :: Ord k => k -> MultiMap k a -> [a] +-- ^ /O(log n)./ Lookup the value at a key in the map. +-- +-- The function will return the corrsponding values as a List, or the +-- empty list if no values are associated witht the given key. +lookup key (MultiMap (_, _, map)) = maybe [] id (Map.lookup key map) + + +empty :: MultiMap k a +-- ^ /O(1)./ The empty multimap. +empty = MultiMap (0, 0, Map.empty) + + +insert :: Ord k => k -> a -> MultiMap k a -> MultiMap k a +-- ^ /O(log n)./ Insert a new key and value in the map. +insert k v (MultiMap (nk, nv, map)) + | Map.member k map = MultiMap (nk, succ nv, Map.insert k (v : map Map.! k) map) + | otherwise = MultiMap (succ nk, succ nv, Map.insert k [v] map) + +delete :: Ord k => k -> MultiMap k a -> MultiMap k a +-- ^ /O(log n)./ Delete a key and all its values from the map. +delete k m@(MultiMap (nk, nv, map)) = case Map.lookup k map of + Just v -> MultiMap (pred nk, nv - fromIntegral (length v), Map.delete k map) + _ -> m + + +map :: (a -> b) -> MultiMap k a -> MultiMap k b +-- ^ Map a function over all values in the map. +map f (MultiMap (nk, nv, map)) = MultiMap (nk, nv, Map.map (P.map f) map) + + +mapKeys :: Ord k2 => (k1 -> k2) -> MultiMap k1 a -> MultiMap k2 a +-- ^ mapKeys f s is the multimap obtained by applying f to each key of s. +mapKeys f (MultiMap (nk, nv, map)) = MultiMap (nk, nv, Map.mapKeys f map) + + +mapWithKey :: (k -> a -> b) -> MultiMap k a -> MultiMap k b +-- ^ Map a function over all key/value pairs in the map. +mapWithKey f (MultiMap (nk, nv, map)) + = MultiMap (nk, nv, Map.mapWithKey (\k -> P.map (f k)) map) + + +foldr :: (a -> b -> b) -> b -> MultiMap k a -> b +-- ^ Fold the values in the map using the given right-associative binary operator. +foldr f e = P.foldr f e . concat . elems + + +foldl :: (a -> b -> a) -> a -> MultiMap k b -> a +-- ^ Fold the values in the map using the given left-associative binary operator. +foldl f e = P.foldl f e . concat . elems + + +foldrWithKey :: (k -> a -> b -> b) -> b -> MultiMap k a -> b +-- ^ /O(n)./ Fold the keys and values in the map using the given right-associative +-- binary operator, taking into account not only the value but also the key. +foldrWithKey f e = P.foldr (uncurry f) e . toList + + +foldlWithKey :: (a -> k -> b -> a) -> a -> MultiMap k b -> a +-- ^ /O(n)./ Fold the keys and values in the map using the given left-associative +-- binary operator, taking into account not only the value but also the key. +foldlWithKey f e = P.foldl (\a (k,v) -> f a k v) e . toList + + +elems :: MultiMap k a -> [[a]] +-- ^ /O(n)./ Return all elements of the multimap in the +-- ascending order of their keys. +-- +-- A list of lists is returned since a key can have +-- multiple values. Use 'concat' to flatten. +elems (MultiMap (_, _, map)) = Map.elems map + + +keys :: MultiMap k a -> [k] +-- ^ /O(n)./ Return all keys of the multimap in ascending order. +keys (MultiMap (_, _, map)) = Map.keys map + + +keysSet :: MultiMap k a -> Set k +-- ^ /O(n)./ The set of all keys of the multimap. +keysSet (MultiMap (_, _, map)) = Map.keysSet map + + +assocs :: MultiMap k a -> [(k, [a])] +-- ^ /O(n)./ Return all key/value pairs in the multimap +-- in ascending key order. +assocs (MultiMap (_, _, map)) = Map.assocs map + + +toMap :: MultiMap k a -> Map k [a] +-- ^ /O(1)./ Return the map of lists. +toMap (MultiMap (_, _, theUnderlyingMap)) = theUnderlyingMap + + +toMapOfSets :: Ord a => MultiMap k a -> Map k (Set a) +-- ^ /O(k*m*log m) where k is the number of keys and m the +-- maximum number of elements associated with a single key/ +toMapOfSets (MultiMap (_, _, map)) = Map.map Set.fromList map + + +toList :: MultiMap k a -> [(k, a)] +-- ^ Return a flattened list of key/value pairs. +toList (MultiMap (_, _, map)) + = concat $ Map.elems $ Map.mapWithKey (\k -> zip (repeat k)) map + + +fromList :: Ord k => [(k, a)] -> MultiMap k a +-- ^ /O(n*log n)/ Create a multimap from a list of key/value pairs. +-- +-- > fromList xs == foldr (uncurry insert) empty +fromList = P.foldr (uncurry insert) empty + + +fromMap :: Map k [a] -> MultiMap k a +-- ^ Turns a map of lists into a multimap. +fromMap map = MultiMap (numKeys, numValues, map) + where + numKeys = fromIntegral $ Map.size map + numValues = fromIntegral $ Map.foldr (\v s -> length v + s) 0 map + + +findMin :: MultiMap k a -> Maybe k +-- ^ /O(log n)/ Find the minimal key of the multimap. +findMin (MultiMap (_, _, map)) + | Map.null map = Nothing + | otherwise = Just $ fst $ Map.findMin map + + +findMax :: MultiMap k a -> Maybe k +-- ^ /O(log n)/ Find the maximal key of the multimap. +findMax (MultiMap (_, _, map)) + | Map.null map = Nothing + | otherwise = Just $ fst $ Map.findMax map + + +findMinWithValues :: MultiMap k a -> Maybe (k, [a]) +-- ^ /O(log n)/ Find the minimal key and the values associated with it. +findMinWithValues (MultiMap (_, _, map)) + | Map.null map = Nothing + | otherwise = Just $ Map.findMin map + + +findMaxWithValues :: MultiMap k a -> Maybe (k, [a]) +-- ^ /O(log n)/ Find the maximal key and the values associated with it. +findMaxWithValues (MultiMap (_, _, map)) + | Map.null map = Nothing + | otherwise = Just $ Map.findMax map + + + + + diff --git a/src/Translate.hss b/src/Translate.hss new file mode 100644 --- /dev/null +++ b/src/Translate.hss @@ -0,0 +1,279 @@ +{-# LANGUAGE Haskell2010 #-} +{-# OPTIONS -Wall #-} + +module Translate where + +import Typomatic +import Utils + +import Foreign.Java.Utils +import Data.Map (Map) + +import Language.Haskell.Reflect +import Language.Java.Reflect +import qualified Language.Java.Reflect.Types as Types + +import Data.Function + +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Map as Map + +import qualified Haskell.X as X + +import Control.Arrow + + +checkedLookup info name = maybe fail id (Map.lookup name info) + where fail = error """class definition for '#{name}' not found.""" + + + +pkgModExports :: ClassInfo -> [JavaClass] -> String +pkgModExports info classes = concatMap (\(t, b) -> """ -- * #{show t}s\n#{b}""") + $ map (second $ concatMap format) + $ X.aggregateAL + $ zip (map classType classes) classes + where + format clazz = + let modName = (classModName info . className) clazz + haskName = takeClassName $ modName + javaName = takeClassName $ className clazz + dataDecl = if classIface clazz then "" else + """ #{dataTName haskName} (..),\n""" + in """ + -- ** #{show $ classType clazz} #{javaName} + -- | For constructors, methods, and so on, see: "#{modName}". + #{tyclTName haskName}, + #{dataDecl}\ + #{newtTName haskName} #{if classEnum clazz then "(..)" else ""}, + """ + + +pkgModImports :: ClassInfo -> [JavaClass] -> String +pkgModImports info classes = concatMap (format . getModName) classes + where + format modName = """import #{modName}__ hiding (info')\n""" + getModName = (classModName info . className) + + +pkgModDecl :: ClassInfo -> [JavaClass] -> String +pkgModDecl info classes = "" + + +classModImports :: ClassInfo -> JavaClass -> String +classModImports info clazz = concatMap format references + where + format package = """import qualified #{package}\n""" + references = Set.toList + $ Set.map (fst . splitClassName . getModName . checkedLookup info) + $ Set.fromList (className clazz : dependencies) + dependencies = classDependencies clazz + getModName = (classModName info . className) + + +classModExports :: ClassInfo -> JavaClass -> String +classModExports info clazz = " -- * Methods\n" ++ concatMap methodExport methodNames + where + methods = List.sortBy (compare `on` methodName) (classMethods clazz) + methodNames = mkMethodNames methods + methodExport name = name ++ ", \n" + + +classModDecl :: ClassInfo -> JavaClass -> String +classModDecl info clazz = concatMap methodDecl $ zip methodNames methods + where + methods = List.sortBy (compare `on` methodName) (classMethods clazz) + methodNames = mkMethodNames methods + methodDecl (name, method) + | arrayTypes = """ + #{name} :: #{signature} + #{name} = Prelude.undefined + """ + | otherwise = """ + #{haddock} + #{name} :: #{signature} + #{name}#{argsDecl} = do + (Prelude.Just clazz) <- JNI.getClass "#{className clazz}" + (Prelude.Just method) <- clazz `JNI.#{getMethod}` #{jniSignature} + #{thisArg}\ + #{readArgs}\ + result <- JNI.#{callMethod} method #{argsRefs} + #{convertResult} result + """ + where + arrayTypes +-- | any isArrayType (methodParams method) = True + | (Just ret) <- fst (methodReturnType method) = isArrayType ret + | otherwise = False + isArrayType x = case x of JArr _ -> True ; _ -> False + isStatic = methodStatic method + javaSignature = fJavaSignature argsInfo + javaReturnType = fJavaReturnType argsInfo + jniSignature = fJniSignature argsInfo + signature = fSignature argsInfo + getMethod = if isStatic then "getStaticMethod" else "getMethod" + callMethod = if isStatic then "callStaticMethodE" else "callMethodE" + args = fArgNames argsInfo + argsNotThis = (if isStatic then id else tail) args + argsInfo = runTypomatic info (typomatic clazz method) + argsDecl = concatMap (' ':) args + argsRefs = concatMap (++ "' ") args + haddock = """ + -- | @#{if isStatic then "static " else "virtual "}\ + #{if methodSynchronized method then "synchronized " else ""}\ + #{if methodNative method then "native " else ""}\ + #{if methodFinal method then "final " else ""}\ + #{javaSignature} -> #{javaReturnType}@""" + thisArg = if isStatic then "" else """ #{head args}' <- JNI.asObject #{head args}\n""" + readArgs = concatMap ((" " ++). uncurry readArg) (zip argsNotThis (map fst $ methodParams method)) + readArg name jtype = case jtype of + JBoolean -> """#{name}' <- JNIS.toBoolean #{name}\n""" + JChar -> """#{name}' <- JNIS.toChar #{name}\n""" + JByte -> """#{name}' <- JNIS.toByte #{name}\n""" + JShort -> """#{name}' <- JNIS.toShort #{name}\n""" + JInt -> """#{name}' <- JNIS.toInt #{name}\n""" + JLong -> """#{name}' <- JNIS.toLong #{name}\n""" + JFloat -> """#{name}' <- JNIS.toFloat #{name}\n""" + JDouble -> """#{name}' <- JNIS.toDouble #{name}\n""" + JObj _ -> """#{name}' <- Prelude.Just <$> JNI.asObject #{name}\n""" + JArr _ -> """#{name}' <- JNIS.asMaybeArrayObject #{name}\n""" + convertResult = ("JNIS." ++) $ case fst (methodReturnType method) of + Nothing -> "toVoidResult" + Just t -> case t of + JBoolean -> "toBooleanResult" + JChar -> "toCharResult" + JByte -> "toByteResult" + JShort -> "toShortResult" + JInt -> "toIntResult" + JLong -> "toLongResult" + JFloat -> "toFloatResult" + JDouble -> "toDoubleResult" + JObj n -> "toObjectResult" + JArr c -> "toArrayResult" + + + +mkMethodNames :: [JavaMethod] -> [String] +mkMethodNames = concatMap (zipWith (flip (++)) (iterate (++"'") "")) + . List.group . map sanitize . map methodName + where + sanitize name + | Char.isUpper (head name) = '_' : name + | name `elem` haskellKeywords = name ++ "'" + | otherwise = name + + +-- Hidden Modules and Boot files + + +classModExports' :: ClassInfo -> JavaClass -> String +classModExports' info clazz = """ + #{tyclTName haskName}, + #{dataTName haskName} (..), + #{newtTName haskName} #{if classEnum clazz then "(..)" else ""}, + """ + where + haskName = takeClassName $ classModName clazz + javaName = takeClassName $ className clazz + + +classBootExports' :: ClassInfo -> JavaClass -> String +classBootExports' info clazz = """ + #{tyclTName haskName}, + #{dataTName haskName} (..), + #{newtTName haskName}, + """ + where + haskName = takeClassName $ classModName clazz + javaName = takeClassName $ className clazz + + +classBootImports' :: ClassInfo -> JavaClass -> String +classBootImports' info clazz + = concatMap (format . classModName) supertypes + where + format modName = """import qualified #{modName}__\n""" + supertypes = map (checkedLookup info) + $ Set.toList + $ Set.fromList (classParents clazz ++ classIfaces clazz) + + +classModImports' :: ClassInfo -> JavaClass -> String +classModImports' info clazz = "" + + +classBootDecl' :: ClassInfo -> JavaClass -> String +classBootDecl' info clazz + | classEnum clazz = """ + class #{tyclTDecl} + data #{newtTDecl} = #{enumConstants} + data #{dataTDecl} = #{dataCDecl} + """ + | otherwise = """ + class #{tyclTDecl} + newtype #{newtTDecl} = #{newtCDecl} JNI.JObject + data #{dataTDecl} = #{dataCDecl} + """ + where baseName = takeClassName $ classModName clazz + params = concatMap (\(p:ps) -> ' ' : Char.toLower p : ps) + $ map (tyVarName . paramName) $ classTypeParams clazz + newtTDecl = newtTName baseName ++ params + newtCDecl = newtCName baseName + dataTDecl = dataTName baseName ++ params + dataCDecl = dataCName baseName ++ params + tyclTDecl = """(JNI.JavaObject this#{context}) => #{tyclTName baseName} this""" + context = concatMap parentContext (classParents clazz) + parentContext parent = """, #{qualifiedName} this""" + where parentClass = info Map.! parent + modName = classModName parentClass + qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName) + enumConstants = concat $ List.intersperse " | " $ map sanitize $ map snd $ classEnumConstants clazz + where sanitize (x:xs) = Char.toUpper x : xs + + +classModDecl' :: ClassInfo -> JavaClass -> String +classModDecl' info clazz + | classEnum clazz = """ + instance JNI.JavaObject (#{newtTDecl}) where + asObject = Prelude.undefined + instance #{tyclTName baseName} (#{newtTDecl}) + instance JNIS.InstanceOf (#{dataTDecl}) where + type CoercedType (#{dataTDecl}) = (#{newtTDecl}) + #{instances} + """ + | otherwise = """ + instance JNI.JavaObject (#{newtTDecl}) where + asObject (#{newtCName baseName} obj) = return obj + instance JNIS.UnsafeCast (#{newtTDecl}) where + unsafeFromJObject obj = return (#{newtCDecl} obj) + instance #{tyclTName baseName} (#{newtTDecl}) + instance JNIS.InstanceOf (#{dataTDecl}) where + type CoercedType (#{dataTDecl}) = (#{newtTDecl}) + coerce o t = do + obj <- JNI.asObject o + (Prelude.Just clazz) <- JNI.getClass "#{fullClassName}" + isInstanceOf <- obj `JNI.isInstanceOf` clazz + if isInstanceOf + then Prelude.Just <$> (JNIS.unsafeFromJObject obj) + else return Prelude.Nothing + #{instances} + """ + where fullClassName = className clazz + baseName = takeClassName $ classModName clazz + params = concatMap (\(p:ps) -> ' ' : Char.toLower p : ps) + $ map (tyVarName . paramName) $ classTypeParams clazz + newtTDecl = newtTName baseName ++ params + newtCDecl = newtCName baseName + dataTDecl = dataTName baseName ++ params + dataCDecl = dataCName baseName ++ params + instances = concatMap parentInstance (classParents clazz) + parentInstance parent = """ + instance #{qualifiedName} (#{newtTDecl}) + """ + where parentClass = info Map.! parent + modName = classModName parentClass + qualifiedName = modName ++ "__." ++ (tyclTName $ takeClassName modName) + +