module NLP.GenI.General (
ePutStr, ePutStrLn, eFlush,
readFile',
lazySlurp,
withTimeout,
exitTimeout,
dropTillIncluding,
trim,
toUpperHead, toLowerHead,
toAlphaNum,
fst3, snd3, thd3,
map',
boundsCheck,
isEmptyIntersect,
groupByFM,
multiGroupByFM,
insertToListMap,
groupAndCount,
combinations,
mapMaybeM,
repList,
mapTree', filterTree,
treeLeaves, preTerminals,
repNode, repAllNode, listRepNode, repNodeByNode,
Interval,
(!+!), ival, showInterval,
BitVector,
showBitVector,
geniBug,
)
where
import Control.Monad (liftM)
import Data.Bits (shiftR, (.&.))
import Data.Char (isDigit, isSpace, toUpper, toLower)
import Data.Function ( on )
import Data.List (foldl', intersect, groupBy, group, sort)
import Data.Tree
import System.IO (hPutStrLn, hPutStr, hFlush, stderr)
import qualified Data.Map as Map
import Control.Concurrent
import Control.Exception
import Data.Dynamic(Typeable, typeOf, TyCon, mkTyCon, mkTyConApp, toDyn)
import Data.Unique
import System.Exit(exitWith, ExitCode(ExitFailure))
import System.IO (openFile, IOMode(ReadMode), hFileSize, hGetBuf)
import System.IO.Unsafe (unsafeInterleaveIO)
import Foreign (mallocForeignPtrBytes, withForeignPtr, ForeignPtr, Ptr, peekElemOff, plusPtr, Word8)
import Data.Char (chr)
ePutStr :: String -> IO ()
ePutStr = hPutStr stderr
ePutStrLn :: String -> IO()
ePutStrLn = hPutStrLn stderr
eFlush :: IO()
eFlush = hFlush stderr
trim :: String -> String
trim = reverse . (dropWhile isSpace) . reverse . (dropWhile isSpace)
dropTillIncluding :: Char -> String -> String
dropTillIncluding c = drop 1 . (dropWhile (/= c))
toUpperHead :: String -> String
toUpperHead [] = []
toUpperHead (h:t) = (toUpper h):t
toLowerHead :: String -> String
toLowerHead [] = []
toLowerHead(h:t) = (toLower h):t
data AlphaNum = A String | N Int deriving Eq
instance Ord AlphaNum where
compare (A s1) (A s2) = compare s1 s2
compare (N s1) (N s2) = compare s1 s2
compare (A _) (N _) = GT
compare (N _) (A _) = LT
toAlphaNum :: String -> [AlphaNum]
toAlphaNum = map readOne . groupBy ((==) `on` isDigit)
where
readOne s
| all isDigit s = N (read s)
| otherwise = A s
fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,x,_) = x
thd3 :: (a,b,c) -> c
thd3 (_,_,x) = x
map' :: (a->b) -> [a] -> [b]
map' _ [] = []
map' f (x:xs) = let a = f x in a `seq` (a:(map' f xs))
boundsCheck :: Int -> [a] -> Bool
boundsCheck s l = s >= 0 && s < length l
isEmptyIntersect :: (Eq a) => [a] -> [a] -> Bool
isEmptyIntersect a b = null $ intersect a b
groupByFM :: (Ord b) => (a -> b) -> [a] -> (Map.Map b [a])
groupByFM fn list =
let addfn x acc key = insertToListMap key x acc
helper acc x = addfn x acc (fn x)
in foldl' helper Map.empty list
multiGroupByFM :: (Ord b) => (a -> [b]) -> [a] -> (Map.Map b [a])
multiGroupByFM fn list =
let addfn x acc key = insertToListMap key x acc
helper acc x = foldl' (addfn x) acc (fn x)
in foldl' helper Map.empty list
insertToListMap :: (Ord b) => b -> a -> Map.Map b [a] -> Map.Map b [a]
insertToListMap k i m =
case Map.lookup k m of
Nothing -> Map.insert k [i] m
Just p -> Map.insert k (i:p) m
groupAndCount :: (Eq a, Ord a) => [a] -> [(a, Int)]
groupAndCount xs =
map (\x -> (head x, length x)) grouped
where grouped = (group.sort) xs
combinations :: [[a]] -> [[a]]
combinations = sequence
mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM _ [] = return []
mapMaybeM f (x:xs) =
f x >>=
(\my -> case my of
Nothing -> mapMaybeM f xs
Just y -> liftM (y:) (mapMaybeM f xs))
repList :: (a->Bool) -> (a->a) -> [a] -> [a]
repList _ _ [] = []
repList pr fn (x:xs)
| pr x = fn x : xs
| otherwise = x : (repList pr fn xs)
mapTree' :: (a->b) -> Tree a -> Tree b
mapTree' fn (Node a []) = let b = fn a in b `seq` Node b []
mapTree' fn (Node a l) = let b = fn a
bs = map' (mapTree' fn) l
in b `seq` bs `seq` Node b bs
filterTree :: (a->Bool) -> Tree a -> [a]
filterTree fn = (filter fn) . flatten
treeLeaves :: Tree a -> [a]
treeLeaves (Node n []) = [n]
treeLeaves (Node _ l ) = concatMap treeLeaves l
preTerminals :: Tree a -> [(a,a)]
preTerminals (Node _ []) = []
preTerminals (Node x ks) =
[ (x,y) | (Node y ys) <- ks, null ys ] ++ concatMap preTerminals ks
repNode :: (Tree a -> Tree a)
-> (Tree a -> Bool)
-> Tree a -> Maybe (Tree a)
repNode fn filt t =
case listRepNode fn filt [t] of
(_, False) -> Nothing
([t2], True) -> Just t2
_ -> geniBug "Either repNode or listRepNode are broken"
repAllNode :: (Tree a -> Tree a) -> (Tree a -> Bool)
-> Tree a -> Tree a
repAllNode fn filt n | filt n = fn n
repAllNode fn filt (Node p ks) = Node p $ map (repAllNode fn filt) ks
listRepNode :: (Tree a -> Tree a)
-> (Tree a -> Bool)
-> [Tree a]
-> ([Tree a], Bool)
listRepNode _ _ [] = ([], False)
listRepNode fn filt (n:l2) | filt n = (fn n : l2, True)
listRepNode fn filt ((n@(Node a l1)):l2) =
case listRepNode fn filt l1 of
(lt1, True) -> ((Node a lt1):l2, True)
_ -> case listRepNode fn filt l2 of
(lt2, flag2) -> (n:lt2, flag2)
repNodeByNode :: (a -> Bool)
-> a -> Tree a -> Tree a
repNodeByNode nfilt rep t =
let tfilt (Node n _) = nfilt n
replaceFn (Node _ k) = Node rep k
in case listRepNode replaceFn tfilt [t] of
([t2], True) -> t2
(_ , False) -> geniBug "Node not found in repNode"
_ -> geniBug "Unexpected result in repNode"
geniBug :: String -> a
geniBug s = error $ "Bug in GenI!\n" ++ s ++
"\nPlease file a report on http://trac.haskell.org/GenI/newticket"
type Interval = (Int,Int)
(!+!) :: Interval -> Interval -> Interval
(!+!) (a1,a2) (b1,b2) = (a1+b1, a2+b2)
ival :: Int -> Interval
ival i = (i,i)
showInterval :: Interval -> String
showInterval (x,y) =
let sign i = if i > 0 then "+" else ""
in if (x==y)
then (sign x) ++ (show x)
else show (x,y)
type BitVector = Integer
showBitVector :: Int -> BitVector -> String
showBitVector min_ 0 = replicate min_ '0'
showBitVector min_ x = showBitVector (min_ 1) (shiftR x 1) ++ (show $ x .&. 1)
readFile' :: FilePath -> IO String
readFile' f = do
h <- openFile f ReadMode
s <- hFileSize h
fp <- mallocForeignPtrBytes (fromIntegral s)
len <- withForeignPtr fp $ \buf -> hGetBuf h buf (fromIntegral s)
lazySlurp fp 0 len
buf_size :: Int
buf_size = 4096 :: Int
lazySlurp :: ForeignPtr Word8 -> Int -> Int -> IO String
lazySlurp fp ix len
| fp `seq` False = undefined
| ix >= len = return []
| otherwise = do
cs <- unsafeInterleaveIO (lazySlurp fp (ix + buf_size) len)
ws <- withForeignPtr fp $ \p -> loop (min (lenix) buf_size 1)
((p :: Ptr Word8) `plusPtr` ix) cs
return ws
where
loop :: Int -> Ptr Word8 -> String -> IO String
loop sublen p acc
| sublen `seq` p `seq` False = undefined
| sublen < 0 = return acc
| otherwise = do
w <- peekElemOff p sublen
loop (sublen1) p (chr (fromIntegral w):acc)
data TimeOut = TimeOut Unique
timeOutTc :: TyCon
timeOutTc = mkTyCon "TimeOut"
instance Typeable TimeOut where
typeOf _ = mkTyConApp timeOutTc []
withTimeout :: Integer
-> IO a
-> IO a
-> IO a
withTimeout secs on_timeout action =
do parent <- myThreadId
i <- newUnique
block $ do
timeout <- forkIO (timeout_thread secs parent i)
Control.Exception.catchDyn
( unblock $ do result <- action
killThread timeout
return result )
( \ex -> case ex of
TimeOut u | u == i -> unblock on_timeout
_ -> killThread timeout >>= throwDyn ex )
where
timeout_thread secs_ parent i =
do threadDelay $ (fromInteger secs_) * 1000000
throwTo parent (DynException $ toDyn $ TimeOut i)
exitTimeout :: IO ()
exitTimeout = exitWith $ ExitFailure 2