diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Miyazawa Akira + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Miyazawa Akira nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/CaboCha.hsc b/Text/CaboCha.hsc new file mode 100644 --- /dev/null +++ b/Text/CaboCha.hsc @@ -0,0 +1,202 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +module Text.CaboCha ( + new, + parse, + parseToChunks, + Token(..), + Chunk(..), + CaboChaString(..) +) + +where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (Exception, throwIO) +import Control.Monad (when, forM) +import qualified Data.ByteString as B (ByteString, packCString, useAsCString) +import qualified Data.Text as T (Text, pack, unpack) +import qualified Data.Text.Encoding as T (encodeUtf8, decodeUtf8) +import Data.Typeable (Typeable) +import Foreign ( + ForeignPtr, FunPtr, Ptr, + newForeignPtr, nullPtr, peek, peekByteOff, withArrayLen, withForeignPtr) +import Foreign.C ( + CChar(..), CFloat(..), CInt(..), CSize(..), + CString, peekCString, withCString) +import Foreign.Storable (sizeOf) +import Foreign.Ptr (plusPtr) + +#include + +newtype CaboCha = + CaboCha { pCaboCha :: ForeignPtr CaboCha } + deriving (Eq, Ord) + +data Tree + +data CaboChaError = + CaboChaError String + deriving (Eq, Ord, Show, Typeable) + +instance Exception CaboChaError + +class CaboChaString s where + toByteString :: s -> B.ByteString + fromByteString :: B.ByteString -> s + +instance CaboChaString String where + toByteString = toByteString . T.pack + fromByteString = T.unpack . fromByteString + +instance CaboChaString B.ByteString where + toByteString = id + fromByteString = id + +instance CaboChaString T.Text where + toByteString = T.encodeUtf8 + fromByteString = T.decodeUtf8 + +data Chunk a = + Chunk { + chunkLink :: Int, + chunkHeadPos :: Int, + chunkFuncPos :: Int, + chunkTokenPos :: Int, + chunkTokenSize :: Int, + chunkScore :: Double, + chunkAdditionalInfo :: Maybe a, + chunkTokens :: [Token a] + } deriving (Eq, Read, Show) + +data Token a = + Token { + tokenSurface :: a, + tokenNormalizedSurface :: a, + tokenFeatureList :: [a], + tokenNE :: Maybe a, + tokenAdditionalInfo :: Maybe a + } deriving (Eq, Read, Show) + +new :: [String] -> IO CaboCha +new args = + withCStrings args $ \argc argv -> do + pcabocha <- cabocha_new (fromIntegral argc) argv + when (pcabocha == nullPtr) $ + throwIO =<< (CaboChaError <$> strerror nullPtr) + CaboCha <$> newForeignPtr p_cabocha_destroy pcabocha + +strerror :: Ptr CaboCha -> IO String +strerror pcabocha = peekCString =<< cabocha_strerror pcabocha + +parse :: CaboChaString a => CaboCha -> a -> IO a +parse cabocha s = + withForeignPtr (pCaboCha cabocha) $ \pc -> + B.useAsCString (toByteString s) $ \pstr -> do + presult <- cabocha_sparse_tostr pc pstr + when (presult == nullPtr) $ + throwIO =<< (CaboChaError <$> strerror pc) + packCString presult + +parseToChunks :: CaboChaString a => CaboCha -> a -> IO [Chunk a] +parseToChunks cabocha s = + withForeignPtr (pCaboCha cabocha) $ \pc -> + B.useAsCString (toByteString s) $ \pstr -> do + ptree <- cabocha_sparse_totree pc pstr + when (ptree == nullPtr) $ + throwIO =<< (CaboChaError <$> strerror pc) + n <- cabocha_tree_token_size ptree + ts <- forM [0 .. (n - 1)] $ \i -> + peekToken =<< cabocha_tree_token ptree i + n' <- cabocha_tree_chunk_size ptree + cs <- forM [0 .. (n' - 1)] $ \i -> do + pchunk <- cabocha_tree_chunk ptree i + peekChunk pchunk ts + cabocha_tree_clear ptree + return cs + +withCStrings :: [String] -> (Int -> Ptr CString -> IO a) -> IO a +withCStrings ss f = + withCStrings' ss $ + \pstrs -> withArrayLen pstrs f + +withCStrings' :: [String] -> ([CString] -> IO a) -> IO a +withCStrings' ss f = go [] ss + where + go acc [] = f $ reverse acc + go acc (s : rest) = withCString s $ \x -> go (x : acc) rest + +peekChunk :: CaboChaString a => Ptr (Chunk a) -> [Token a] -> IO (Chunk a) +peekChunk pchunk tokens = do + i <- (fromIntegral :: CSize -> Int) <$> (#peek cabocha_chunk_t, token_pos) pchunk + n <- (fromIntegral :: CSize -> Int) <$> (#peek cabocha_chunk_t, token_size) pchunk + Chunk + <$> ((fromIntegral :: CInt -> Int) <$> (#peek cabocha_chunk_t, link) pchunk) + <*> ((fromIntegral :: CSize -> Int) <$> (#peek cabocha_chunk_t, head_pos) pchunk) + <*> ((fromIntegral :: CSize -> Int) <$> (#peek cabocha_chunk_t, func_pos) pchunk) + <*> return i + <*> return n + <*> ((realToFrac :: CFloat -> Double) <$> (#peek cabocha_chunk_t, score) pchunk) + <*> (packOptionalCString =<< (#peek cabocha_chunk_t, additional_info) pchunk) + <*> return ((take n . drop i) tokens) + +peekToken :: CaboChaString a => Ptr (Token a) -> IO (Token a) +peekToken ptoken = + Token + <$> (packCString =<< (#peek cabocha_token_t, surface) ptoken) + <*> (packCString =<< (#peek cabocha_token_t, normalized_surface) ptoken) + <*> (packCStrings =<< (#peek cabocha_token_t, feature_list) ptoken) + <*> (packOptionalCString =<< (#peek cabocha_token_t, ne) ptoken) + <*> (packOptionalCString =<< (#peek cabocha_token_t, additional_info) ptoken) + +packCString :: CaboChaString a => CString -> IO a +packCString cstr = fromByteString <$> B.packCString cstr + +packCStrings :: CaboChaString b => Ptr (Ptr CChar) -> IO [b] +packCStrings pstrs = + peek pstrs >>= \pstr -> + if (pstr == nullPtr) + then return [] + else do + let size = sizeOf (undefined :: Ptr CChar) + s <- packCString pstr + ss <- packCStrings (pstrs `plusPtr` size) + return (s : ss) + +packOptionalCString :: CaboChaString a => CString -> IO (Maybe a) +packOptionalCString pstr = + if pstr == nullPtr + then return Nothing + else Just <$> packCString pstr + +foreign import ccall "cabocha_new" + cabocha_new :: CInt -> Ptr CString -> IO (Ptr CaboCha) + +foreign import ccall "cabocha_strerror" + cabocha_strerror :: Ptr CaboCha -> IO CString + +foreign import ccall "cabocha_sparse_tostr" + cabocha_sparse_tostr :: Ptr CaboCha -> CString -> IO CString + +foreign import ccall "&cabocha_destroy" + p_cabocha_destroy :: FunPtr (Ptr CaboCha -> IO ()) + +foreign import ccall "cabocha_sparse_totree" + cabocha_sparse_totree :: Ptr CaboCha -> CString -> IO (Ptr Tree) + +foreign import ccall "cabocha_tree_chunk" + cabocha_tree_chunk :: Ptr Tree -> CSize -> IO (Ptr (Chunk a)) + +foreign import ccall "cabocha_tree_chunk_size" + cabocha_tree_chunk_size :: Ptr Tree -> IO CSize + +foreign import ccall "cabocha_tree_token" + cabocha_tree_token :: Ptr Tree -> CSize -> IO (Ptr (Token a)) + +foreign import ccall "cabocha_tree_token_size" + cabocha_tree_token_size :: Ptr Tree -> IO CSize + +foreign import ccall "cabocha_tree_clear" + cabocha_tree_clear :: Ptr Tree -> IO () diff --git a/cabocha.cabal b/cabocha.cabal new file mode 100644 --- /dev/null +++ b/cabocha.cabal @@ -0,0 +1,31 @@ +name: cabocha +version: 0.1.0.0 +description: A Haskell binding to CaboCha +license: BSD3 +license-file: LICENSE +author: Miyazawa Akira +maintainer: Miyazawa Akira +category: Natural Language Processing +build-type: Simple +homepage: http://github.com/pecorarista/hscabocha +cabal-version: >=1.10 +extra-source-files: test/*.hs + +library + exposed-modules: Text.CaboCha + build-depends: + base >= 4.7 && < 5, + bytestring, + text + ghc-options: -Wall -O2 + extra-libraries: cabocha + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: + base >= 4.7 && < 5, + cabocha, + text-format diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,43 @@ +import qualified Text.CaboCha as C + +main :: IO () +main = do + c <- C.new ["cabocha", "-f3", "-n1"] + let s = "太郎は花子が読んでいる本を次郎に渡した" + putStrLn =<< C.parse c s + chunks <- C.parseToChunks c s + mapM_ printChunk chunks + +printToken :: C.Token String -> IO () +printToken t = do + putStrLn "## token" + putStrLn $ "surface: " ++ C.tokenSurface t + putStrLn $ "normalized surface: " ++ C.tokenNormalizedSurface t + case C.tokenNE t of + Just x + | '0' `elem` x -> putStrLn "named entity: no" + | otherwise -> return () + Nothing -> return () + case C.tokenAdditionalInfo t of + Just x -> putStrLn $ "additional info: " ++ x + _ -> return () + putStrLn $ joint ", " (C.tokenFeatureList t) + +printChunk :: C.Chunk String -> IO () +printChunk c = do + putStrLn "# chunk" + putStrLn $ "link: " ++ show (C.chunkLink c) + putStrLn $ "head position: " ++ show (C.chunkHeadPos c) + putStrLn $ "func. position: " ++ show (C.chunkFuncPos c) + putStrLn $ "token position: " ++ show (C.chunkTokenPos c) + putStrLn $ "token size: " ++ show (C.chunkTokenSize c) + putStrLn $ "score: " ++ show (C.chunkScore c) + case C.chunkAdditionalInfo c of + Just x -> putStrLn $ "additional info: " ++ x + _ -> return () + mapM_ printToken (C.chunkTokens c) + +joint :: String -> [String] -> String +joint _ [] = [] +joint _ [xs] = xs +joint glue (x:xs) = x ++ glue ++ joint glue xs