diff --git a/NLP/WordNet.hs b/NLP/WordNet.hs --- a/NLP/WordNet.hs +++ b/NLP/WordNet.hs @@ -61,19 +61,12 @@ ) where -import Prelude hiding (catch) -import Data.Array -import GHC.Arr (unsafeIndex) -import GHC.IO.Handle +import Prelude import Data.Tree -import Data.IORef -import Data.Dynamic import qualified Data.Set as Set -import Numeric (readHex, readDec) import System.IO.Unsafe import NLP.WordNet.Common -import NLP.WordNet.Consts import NLP.WordNet.Util import NLP.WordNet.Types @@ -144,7 +137,7 @@ strM <- P.getIndexString ?wne word pos case strM of Nothing -> return Nothing - Just s -> unsafeInterleaveIO $ P.indexLookup ?wne word pos + Just _ -> unsafeInterleaveIO $ P.indexLookup ?wne word pos -- | This takes an 'Overview' (see 'getOverview'), a 'POS' and a 'SenseType' and returns -- a list of search results. If 'SenseType' is 'AllSenses', there will be one @@ -159,9 +152,9 @@ let numSenses = T.indexSenseCount idx skL <- mapMaybe id `liftM` unsafeInterleaveIO ( - mapM (\sense -> do - skey <- P.indexToSenseKey ?wne idx sense - return (liftM ((,) sense) skey) + mapM (\sense' -> do + skey <- P.indexToSenseKey ?wne idx sense' + return (liftM ((,) sense') skey) ) (sensesOf numSenses sense) ) r <- unsafeInterleaveIO $ mapM (\ (snum, skey) -> @@ -180,7 +173,7 @@ -- | This takes a 'Word', a 'POS' and a 'SenseType' and returns -- the equivalent of first running 'getOverview' and then 'searchByOverview'. search :: WN (Word -> POS -> SenseType -> [SearchResult]) -search word pos sense = searchByOverview (getOverview word) pos sense +search word = searchByOverview (getOverview word) -- | This takes a 'Key' (see 'srToKey' and 'srFormKeys') and looks it -- up in the databse. @@ -236,6 +229,7 @@ addToBag = flip (:) isEmptyBag = null splitBag (x:xs) = (x, xs) + splitBag [] = undefined -- | A very slow queue based on lists. newtype Queue a = Queue [a] deriving (Show) @@ -245,6 +239,7 @@ addToBag (Queue l) a = Queue (l++[a]) isEmptyBag (Queue l) = null l splitBag (Queue (x:xs)) = (x, Queue xs) + splitBag (Queue []) = undefined addListToBag (Queue l) l' = Queue (l ++ l') -- | An empty stack. @@ -314,6 +309,11 @@ t1 = closureOn Hypernym sr1 t2 = closureOn Hypernym sr2 +meetSearchPaths :: Bag b (Tree SearchResult) + => b (Tree SearchResult) + -> Tree SearchResult + -> Tree SearchResult + -> Maybe ([SearchResult], SearchResult, [SearchResult]) meetSearchPaths emptyBg t1 t2 = let srch b v1 v2 bag1 bag2 | isEmptyBag bag1 && isEmptyBag bag2 = Nothing @@ -330,9 +330,5 @@ bag2 (addListToBag bag1' chl) -- flip the order :) in srch True [] [] (addToBag emptyBg t1) (addToBag emptyBg t2) where - containsResult v sl = sl `elem` map (flip srWords AllSenses) v + containsResult v sl = sl `elem` map (`srWords` AllSenses) v addResult v sr = sr:v - -personTree = runWordNetQuiet (closureOn Hypernym (head $ search "person" Noun AllSenses)) -organizationTree = runWordNetQuiet (closureOn Hypernym (head $ search "organization" Noun AllSenses)) - diff --git a/NLP/WordNet/Common.hs b/NLP/WordNet/Common.hs --- a/NLP/WordNet/Common.hs +++ b/NLP/WordNet/Common.hs @@ -1,16 +1,8 @@ -module NLP.WordNet.Common - ( - module Data.Char, - module Data.List, - module Data.Maybe, - module Control.Exception, - module Control.Monad, - ) - where +module NLP.WordNet.Common (module X) where -import Prelude hiding (catch) -import Data.Char -import Data.List -import Data.Maybe -import Control.Exception -import Control.Monad +import Prelude +import Data.Char as X +import Data.List as X +import Data.Maybe as X +import Control.Exception as X +import Control.Monad as X diff --git a/NLP/WordNet/Consts.hs b/NLP/WordNet/Consts.hs --- a/NLP/WordNet/Consts.hs +++ b/NLP/WordNet/Consts.hs @@ -1,9 +1,14 @@ module NLP.WordNet.Consts where -import Data.List (intersperse) +import Data.String import System.FilePath (joinPath) +makePath :: [FilePath] -> FilePath makePath = joinPath + +dictDir :: IsString a => a +defaultPath :: IsString a => a +defaultBin :: IsString a => a #if defined (UNIX) dictDir = "/dict" diff --git a/NLP/WordNet/PrimTypes.hs b/NLP/WordNet/PrimTypes.hs --- a/NLP/WordNet/PrimTypes.hs +++ b/NLP/WordNet/PrimTypes.hs @@ -10,14 +10,17 @@ -- | The basic part of speech type, either a 'Noun', 'Verb', 'Adj'ective or 'Adv'erb. data POS = Noun | Verb | Adj | Adv deriving (Eq, Ord, Show, Ix, Typeable) +allPOS :: [POS] allPOS = [Noun ..] data EPOS = POS POS | Satellite | AdjSatellite | IndirectAnt | DirectAnt | UnknownEPos | Pertainym deriving (Eq, Ord, Typeable) +fromEPOS :: EPOS -> POS fromEPOS (POS p) = p fromEPOS _ = Adj +allEPOS :: [EPOS] allEPOS = [POS Noun ..] instance Enum POS where @@ -25,6 +28,7 @@ toEnum 2 = Verb toEnum 3 = Adj toEnum 4 = Adv + toEnum _ = undefined fromEnum Noun = 1 fromEnum Verb = 2 fromEnum Adj = 3 @@ -39,27 +43,29 @@ toEnum 4 = POS Adv toEnum 5 = Satellite toEnum 6 = AdjSatellite + toEnum _ = undefined fromEnum (POS Noun) = 1 fromEnum (POS Verb) = 2 fromEnum (POS Adj) = 3 fromEnum (POS Adv) = 4 fromEnum Satellite = 5 fromEnum AdjSatellite = 6 + fromEnum _ = 0 enumFrom i = enumFromTo i AdjSatellite enumFromThen i j = enumFromThenTo i j AdjSatellite instance Show EPOS where showsPrec i (POS p) = showsPrec i p - showsPrec i (Satellite) = showString "Satellite" - showsPrec i (AdjSatellite) = showString "AdjSatellite" - showsPrec i (IndirectAnt) = showString "IndirectAnt" - showsPrec i (DirectAnt) = showString "DirectAnt" - showsPrec i (Pertainym) = showString "Pertainym" - showsPrec i (UnknownEPos) = showString "UnknownEPos" + showsPrec _ (Satellite) = showString "Satellite" + showsPrec _ (AdjSatellite) = showString "AdjSatellite" + showsPrec _ (IndirectAnt) = showString "IndirectAnt" + showsPrec _ (DirectAnt) = showString "DirectAnt" + showsPrec _ (Pertainym) = showString "Pertainym" + showsPrec _ (UnknownEPos) = showString "UnknownEPos" instance Ix EPOS where range (i,j) = [i..j] - index (i,j) a = fromEnum a - fromEnum i + index (i,_) a = fromEnum a - fromEnum i inRange (i,j) a = a `elem` [i..j] @@ -69,6 +75,7 @@ readEPOS "a" = POS Adj readEPOS "r" = POS Adv readEPOS "s" = Satellite +readEPOS _ = undefined data WordNetEnv = WordNetEnv { @@ -84,6 +91,7 @@ warnAbout :: String -> SomeException -> IO () } +wordNetEnv0 :: WordNetEnv wordNetEnv0 = WordNetEnv { dataHandles = undefined, excHandles = undefined, @@ -127,6 +135,7 @@ headSense :: SenseType } -- deriving (Show) +synset0 :: Synset synset0 = Synset 0 UnknownEPos (-1) undefined [] Nothing [] [] "" Nothing (-1) "" AllSenses -- | The basic type which holds search results. Its 'Show' instance simply @@ -156,6 +165,7 @@ indexOffsets :: [Offset] } deriving (Eq, Ord, Show, Typeable) +index0 :: Index index0 = Index "" (POS Noun) (-1) [] (-1) [] -- | The different types of relations which can hold between WordNet Synsets. diff --git a/NLP/WordNet/Prims.hs b/NLP/WordNet/Prims.hs --- a/NLP/WordNet/Prims.hs +++ b/NLP/WordNet/Prims.hs @@ -31,11 +31,11 @@ import Numeric (readHex, readDec) import Data.Char (toLower, isSpace) import Data.Array +import Data.Foldable (forM_) import Control.Exception -import Control.Monad (when, liftM, mplus) -import Data.List (findIndex, find) +import Control.Monad (when, liftM, mplus, unless) +import Data.List (findIndex, find, elemIndex) import Data.Maybe (isNothing, fromJust, isJust, fromMaybe) -import GHC.IO.Handle -- (openFileEx, BinaryMode(..)) import NLP.WordNet.PrimTypes import NLP.WordNet.Util @@ -61,12 +61,12 @@ searchdir <- case mSearchdir of { Nothing -> getDefaultSearchDir ; Just d -> return d } let warn = fromMaybe (\s e -> hPutStrLn stderr (s ++ "\n" ++ show e)) mWarn version <- tryMaybe $ getEnv "WNDBVERSION" - dHands <- mapM (\pos -> do + dHands <- mapM (\pos' -> do idxH <- openFileEx - (makePath [searchdir, "index." ++ partName pos]) + (makePath [searchdir, "index." ++ partName pos']) (BinaryMode ReadMode) dataH <- openFileEx - (makePath [searchdir, "data." ++ partName pos]) + (makePath [searchdir, "data." ++ partName pos']) (BinaryMode ReadMode) return (idxH, dataH) ) allPOS @@ -84,10 +84,10 @@ idx <- openFileEx (makePath [searchdir, "sentidx.vrb"]) (BinaryMode ReadMode) snt <- openFileEx (makePath [searchdir, "sents.vrb" ]) (BinaryMode ReadMode) return (idx, snt) - mHands <- mapM (\pos -> openFileEx - (makePath [searchdir, partName pos ++ ".exc"]) + mHands <- mapM (\pos' -> openFileEx + (makePath [searchdir, partName pos' ++ ".exc"]) (BinaryMode ReadMode)) allPOS - return $ WordNetEnv + return WordNetEnv { dataHandles = listArray (Noun, Adv) dHands, excHandles = listArray (Noun, Adv) mHands, senseHandle = sense, @@ -116,7 +116,7 @@ closeWordNet wne = do mapM_ (\ (h1,h2) -> hClose h1 >> hClose h2) (elems (dataHandles wne)) mapM_ hClose (elems (excHandles wne)) - mapM_ (\x -> when (isJust x) $ hClose (fromJust x)) + mapM_ (`forM_` hClose) [senseHandle wne, countListHandle wne, keyIndexHandle wne, revKeyIndexHandle wne, liftM fst (vSentHandle wne), liftM snd (vSentHandle wne)] @@ -138,15 +138,15 @@ -- be built using indexToSenseKey. getSynsetForSense :: WordNetEnv -> SenseKey -> IO (Maybe Synset) getSynsetForSense wne _ | isNothing (senseHandle wne) = ioError $ userError "no sense dictionary" -getSynsetForSense wne key = do +getSynsetForSense wne key' = do l <- binarySearch (fromJust $ senseHandle wne) - (senseKeyString key) -- ++ " " ++ charForPOS (senseKeyPOS key)) + (senseKeyString key') -- ++ " " ++ charForPOS (senseKeyPOS key)) case l of Nothing -> return Nothing - Just l -> do offset <- maybeRead $ takeWhile (not . isSpace) $ - drop 1 $ dropWhile (not . isSpace) l - ss <- readSynset wne (senseKeyPOS key) offset (senseKeyWord key) + Just l' -> do offset <- maybeRead $ takeWhile (not . isSpace) $ + drop 1 $ dropWhile (not . isSpace) l' + ss <- readSynset wne (senseKeyPOS key') offset (senseKeyWord key') return (Just ss) -- | readSynset takes a part of speech, and an offset (the offset can be found @@ -178,7 +178,7 @@ -- print (toks, ptrCountS, ptrCount) wrds' <- readWords ss1 wrds let ss2 = ss1 { ssWords = wrds', - whichWord = findIndex (==w) wrds } + whichWord = elemIndex w wrds } let (ptrs,rest3) = splitAt (ptrCount*4) rest2 let (fp,ss3) = readPtrs (False,ss2) ptrs let ss4 = if fp && searchPos == Adj && ssType ss3 == UnknownEPos @@ -187,23 +187,23 @@ let (ss5,rest4) = if searchPos /= Verb then (ss4, rest3) - else let (fcountS:rest4) = rest3 - (synPtrs, rest5) = splitAt (read fcountS * 3) rest4 + else let (fcountS:_) = rest3 + (_ , rest5) = splitAt (read fcountS * 3) rest4 in (ss4, rest5) let ss6 = ss5 { defn = unwords $ drop 1 rest4 } return ss6 where - readWords ss (w:lid:xs) = do - let s = map toLower $ replaceChar ' ' '_' w + readWords ss (w':lid:xs) = do + let s = map toLower $ replaceChar ' ' '_' w' idx <- indexLookup wne s (fromEPOS $ pos ss) -- print (w,st,idx) let posn = case idx of Nothing -> Nothing - Just ix -> findIndex (==hereIAm ss) (indexOffsets ix) + Just ix -> elemIndex (hereIAm ss) (indexOffsets ix) rest <- readWords ss xs - return ((w, fst $ head $ readHex lid, maybe AllSenses SenseNumber posn) : rest) + return ((w', fst $ head $ readHex lid, maybe AllSenses SenseNumber posn) : rest) readWords _ _ = return [] readPtrs (fp,ss) (typ:off:ppos:lexp:xs) = let (fp',ss') = readPtrs (fp,ss) xs @@ -231,20 +231,20 @@ case findIndex ((==indexWord idx) . map toLower) (map (\ (w,_,_) -> w) $ ssWords ss2) of Nothing -> return Nothing Just j -> do - let skey = if ssType ss2 == Satellite - then indexWord idx ++ "%" ++ show (fromEnum Satellite) ++ ":" ++ + let skey = ((indexWord idx ++ "%") ++) (if ssType ss2 == Satellite + then show (fromEnum Satellite) ++ ":" ++ padTo 2 (show $ fnum ss2) ++ ":" ++ headWord ss2 ++ ":" ++ padTo 2 (show $ headSense ss2) - else indexWord idx ++ "%" ++ show (fromEnum $ pos ss2) ++ ":" ++ + else show (fromEnum $ pos ss2) ++ ":" ++ padTo 2 (show $ fnum ss2) ++ ":" ++ - padTo 2 (show $ lexId ss2 j) ++ "::" + padTo 2 (show $ lexId ss2 j) ++ "::") return (Just $ SenseKey cpos skey (indexWord idx)) where followSatellites ss | ssType ss == Satellite = case find (\ (f,_,_,_,_) -> f == Similar) (forms ss) of Nothing -> return ss - Just (f,offset,p,j,k) -> do + Just (_,offset,p,_,_) -> do adjss <- readSynset wne (fromEPOS p) offset "" case ssWords adjss of (hw,_,hs):_ -> return (ss { headWord = map toLower hw, @@ -254,8 +254,8 @@ -- indexLookup takes a word and part of speech and gives back its index. indexLookup :: WordNetEnv -> String -> POS -> IO (Maybe Index) -indexLookup wne w pos = do - ml <- binarySearch (fst (dataHandles wne ! pos)) w +indexLookup wne w pos' = do + ml <- binarySearch (fst (dataHandles wne ! pos')) w case ml of Nothing -> return Nothing Just l -> do @@ -294,16 +294,17 @@ else binarySearch' top (bot-1) ((top+bot-1) `div` 2) else do l <- hGetLine h - let key = takeWhile (/=' ') l - if key == s + let key' = takeWhile (/=' ') l + if key' == s then return (Just l) else case (bot - top) `div` 2 of 0 -> return Nothing - d -> case key `compare` s of + d -> case key' `compare` s of LT -> binarySearch' mid bot (mid + d) GT -> binarySearch' top mid (top + d) + EQ -> undefined readUntilNL = do eof <- hIsEOF h - if eof - then return () - else do hGetLine h; return () + unless eof $ do + hGetLine h + return () diff --git a/NLP/WordNet/Types.hs b/NLP/WordNet/Types.hs --- a/NLP/WordNet/Types.hs +++ b/NLP/WordNet/Types.hs @@ -76,7 +76,6 @@ ) where -import System.IO.Unsafe import Data.List import Data.Maybe @@ -154,7 +153,7 @@ -- | This gives the actual words used to describe the Synset of a search result. srWords :: SearchResult -> SenseType -> [Word] -srWords sr t = nub . map fst3 . filter ((isType t) . thr3) . ssWords . srSynset $ sr +srWords sr t = nub . map fst3 . filter (isType t . thr3) . ssWords . srSynset $ sr where isType AllSenses _ = True isType _ AllSenses = True isType (SenseNumber n) (SenseNumber m) = n == m @@ -185,7 +184,3 @@ _ -> case ssType (srSynset sr) of POS pp -> pp _ -> Adj - -instance Show SearchResult where - showsPrec i (SearchResult { srSynset = ss }) = - showChar '<' . showString (unwords $ map fst3 $ ssWords ss) . showChar '>' diff --git a/NLP/WordNet/Util.hs b/NLP/WordNet/Util.hs --- a/NLP/WordNet/Util.hs +++ b/NLP/WordNet/Util.hs @@ -2,27 +2,37 @@ import NLP.WordNet.PrimTypes +#if MIN_VERSION_base(4,6,0) +import Prelude +#else import Prelude hiding (catch) +#endif import Control.Exception +import Control.Monad import Data.Char (toLower) import Data.List (nub) import Data.Maybe (fromMaybe) +import Data.String import GHC.IO.Handle import System.IO data IOModeEx = BinaryMode IOMode | AsciiMode IOMode deriving (Eq, Ord, Show, Read) +openFileEx :: FilePath -> IOModeEx -> IO Handle openFileEx fp (BinaryMode md) = openBinaryFile fp md openFileEx fp (AsciiMode md) = openFile fp md +fst3 :: (a, b, c) -> a fst3 (a,_,_) = a +snd3 :: (a, b, c) -> b snd3 (_,b,_) = b +thr3 :: (a, b, c) -> c thr3 (_,_,c) = c maybeRead :: (Read a, Monad m) => String -> m a maybeRead s = - case readsPrec 0 s of + case reads s of (a,_):_ -> return a _ -> fail "error parsing string" @@ -30,8 +40,11 @@ matchN n l | length l >= n = return l | otherwise = fail "expecting more tokens" -lexId x n = (\ (_,i,_) -> i) $ (ssWords x !! n) -padTo n s = reverse $ take n $ (reverse s ++ repeat '0') +lexId :: Synset -> Int -> Int +lexId x n = (\ (_,i,_) -> i) (ssWords x !! n) + +padTo :: Int -> String -> String +padTo n s = reverse $ take n (reverse s ++ repeat '0') sensesOf :: Int {- num senses -} -> SenseType -> [Int] sensesOf n AllSenses = [1..n] @@ -42,25 +55,26 @@ -- utility functions +charForPOS :: IsString a => POS -> a charForPOS (Noun) = "n" charForPOS (Verb) = "v" charForPOS (Adj) = "a" charForPOS (Adv) = "r" tryMaybe :: IO a -> IO (Maybe a) -tryMaybe a = (a >>= return . Just) `catch` (\(_ :: SomeException) -> return Nothing) +tryMaybe a = liftM Just a `catch` (\(_ :: SomeException) -> return Nothing) tryMaybeWarn :: Exception e => (e -> IO ()) -> IO a -> IO (Maybe a) -tryMaybeWarn warn a = (a >>= return . Just) `catch` (\e -> warn e >> return Nothing) +tryMaybeWarn warn a = liftM Just a `catch` (\e -> warn e >> return Nothing) partName :: POS -> String partName = map toLower . show cannonWNString :: String -> [String] cannonWNString s' - | not ('_' `elem` s) && - not ('-' `elem` s) && - not ('.' `elem` s) = [s] + | notElem '_' s && + notElem '-' s && + notElem '.' s = [s] | otherwise = nub [s, replaceChar '_' '-' s, @@ -70,11 +84,13 @@ ] where s = map toLower s' -replaceChar from to [] = [] +replaceChar :: Eq a => a -> a -> [a] -> [a] +replaceChar _ _ [] = [] replaceChar from to (c:cs) | c == from = to : replaceChar from to cs | otherwise = c : replaceChar from to cs +getPointerType :: (Eq a, IsString a) => a -> Form getPointerType s = fromMaybe Unknown $ lookup s l where l = diff --git a/WordNet.cabal b/WordNet.cabal --- a/WordNet.cabal +++ b/WordNet.cabal @@ -1,5 +1,5 @@ Name: WordNet -Version: 1.0.0 +Version: 1.1.0 Description: A pure-Haskell interface to the WordNet lexical database of English. Depends on the WordNet database, but not on the WordNet source code. @@ -12,10 +12,10 @@ Build-Depends: base, filepath Build-Type: Simple Cabal-Version: >= 1.8 +Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.7.20130824 Library Build-depends: base == 4.*, containers, filepath, array - Exposed-Modules: NLP.WordNet @@ -27,4 +27,4 @@ NLP.WordNet.Prims NLP.WordNet.Types - Extensions: CPP, DeriveDataTypeable, ImplicitParams, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables + Extensions: CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, ImplicitParams, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables