j2hs 0.99 → 0.99.1
raw patch · 4 files changed
+903/−5 lines, 4 files
Files
- dist/build/j2hs/j2hs-tmp/Translate.hs +334/−0
- j2hs.cabal +7/−5
- src/MultiMap.hs +283/−0
- src/Translate.hss +279/−0
+ dist/build/j2hs/j2hs-tmp/Translate.hs view
@@ -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)++
j2hs.cabal view
@@ -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
+ src/MultiMap.hs view
@@ -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+++++
+ src/Translate.hss view
@@ -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)++