diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2012, IPI PAN +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 IPI PAN 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/NLP/Morfeusz.hsc b/NLP/Morfeusz.hsc new file mode 100644 --- /dev/null +++ b/NLP/Morfeusz.hsc @@ -0,0 +1,271 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | The module provides 'asDAG', 'asPaths' and 'asPath' wrapper functions +-- which use the Morfeusz library to analyse input sentences. +-- The first one represents analysis results as a directed acylic graph +-- (DAG) with edges labeled with 'Token's. The DAG representation is needed +-- when the input word has multiple correct segmentations. +-- +-- >>> :m NLP.Morfeusz +-- >>> :set -XOverloadedStrings +-- >>> let wordAsDAG = head . lefts . asDAG +-- >>> mapM_ print . wordAsDAG $ "miałem" +-- Edge {from = 0, to = 1, label = Token {orth = "mia\322", interps = [Interp {base = "mie\263", msd = "praet:sg:m1.m2.m3:imperf"}]}} +-- Edge {from = 0, to = 2, label = Token {orth = "mia\322em", interps = [Interp {base = "mia\322", msd = "subst:sg:inst:m3"}]}} +-- Edge {from = 1, to = 2, label = Token {orth = "em", interps = [Interp {base = "by\263", msd = "aglt:sg:pri:imperf:wok"}]}} +-- +-- Alternatively you can use the 'asPaths' function to see all paths instead of a DAG. +-- +-- >>> let wordAsPaths = head . lefts . asPaths +-- >>> mapM_ print . wordAsPaths $ "miałem" +-- [Token {orth = "mia\322em", interps = [Interp {base = "mia\322", msd = "subst:sg:inst:m3"}]}] +-- [Token {orth = "mia\322", interps = [Interp {base = "mie\263", msd = "praet:sg:m1.m2.m3:imperf"}]},Token {orth = "em", interps = [Interp {base = "by\263", msd = "aglt:sg:pri:imperf:wok"}]}] +-- +-- The last analysis function, 'asPath', takes paths extracted using the 'asPaths' function +-- and arbitrarily chooses one of them. While it returns only part of the analysis result, +-- it is also the easiest to use. +-- +-- >>> mapM_ print . asPath $ "zdanie ze spacjami" +-- Left (Token {orth = "zdanie", interps = [Interp {base = "zda\263", msd = "ger:sg:nom.acc:n2:perf:aff"},Interp {base = "zdanie", msd = "subst:sg:nom.acc.voc:n2"}]}) +-- Right " " +-- Left (Token {orth = "ze", interps = [Interp {base = "z", msd = "prep:inst:wok"},Interp {base = "z", msd = "prep:gen.acc:wok"}]}) +-- Right " " +-- Left (Token {orth = "spacjami", interps = [Interp {base = "spacja", msd = "subst:pl:inst:f"}]}) +-- +-- Use the 'lefts' function when you want to remove spaces from the result. + +module NLP.Morfeusz +( +-- * Types + DAG +, Edge (..) +, Token (..) +, Interp (..) +, Space + +-- * Sentence analysis +, asDAG +, asPaths +, asPath + +-- * Utilities +, toPaths +, mapL +, concatL +, concatMapL + +, module Data.Either +) where + +import System.IO.Unsafe (unsafePerformIO) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (when) +import Control.Monad.State (evalState, put, get) +import Data.Function (on) +import Data.List (groupBy) +import Data.Char (isSpace) +import Data.Either +import qualified Data.Map as M +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Foreign hiding (unsafePerformIO) +import Foreign.C.Types +import Foreign.C.String (CString) + +import NLP.Morfeusz.Lock (lock) + +#include "morfeusz.h" + +-- | Morfeusz options +newtype MorfOption = MorfOption { unMorfOption :: CInt } + deriving (Eq, Show) + +newtype Encoding = Encoding { unEncoding :: CInt } + deriving (Eq, Show) + +newtype WhiteSpace = WhiteSpace { unWhiteSpace :: CInt } + deriving (Eq, Show) + +#{ enum MorfOption, MorfOption + , encoding = MORFOPT_ENCODING + , whitespace = MORFOPT_WHITESPACE } + +#{ enum Encoding, Encoding + , utf8 = MORFEUSZ_UTF_8 + , iso8859_2 = MORFEUSZ_ISO8859_2 + , cp1250 = MORFEUSZ_CP1250 + , cp852 = MORFEUSZ_CP852 } + +#{ enum WhiteSpace, WhiteSpace + , skip_whitespace = MORFEUSZ_SKIP_WHITESPACE + , keep_whitespace = MORFEUSZ_KEEP_WHITESPACE } + +-- | Set the encoding. +setEncoding :: Encoding -> IO Bool +setEncoding enc = (1 ==) <$> + c_morfeusz_set_option (unMorfOption encoding) (unEncoding enc) + +-- | Set the Morfeusz whitespace option. +setSpace :: WhiteSpace -> IO Bool +setSpace spc = (1 ==) <$> + c_morfeusz_set_option (unMorfOption whitespace) (unWhiteSpace spc) + +-- | A directed edge with label of type @a@ between nodes of type 'Int'. +data Edge a = Edge + { from :: Int + , to :: Int + , label :: a } + deriving (Eq, Ord, Show, Functor) + +-- | Raw morphosyntactic interpretation as presented by the Morfeusz. +data RawInterp = RawInterp + { _orth :: T.Text + , _base :: Maybe T.Text + , _msd :: Maybe T.Text } + deriving (Eq, Ord, Show) + +-- | A token with a list of recognized interpretations. If the list of +-- interpretations is empty, the token is unknown to the Morfeusz. +data Token = Token + { orth :: T.Text + , interps :: [Interp] } + deriving (Show) + +-- | An interpretation of the word. +data Interp = Interp + { base :: T.Text + , msd :: T.Text } + deriving (Show) + +-- | A space. +type Space = T.Text + +-- | We only provide the peek functionality. +instance Storable (Edge RawInterp) where + sizeOf _ = (#size InterpMorf) + alignment _ = alignment (undefined :: CString) -- or CInt ? + peek ptr = do + from <- getInt ((#peek InterpMorf, p) ptr) + to <- getInt ((#peek InterpMorf, k) ptr) + (orth, base, msd) <- if from == -1 + then return ("", Nothing, Nothing) + else (,,) + <$> getText ((#peek InterpMorf, forma) ptr) + <*> getTextMaybe ((#peek InterpMorf, haslo) ptr) + <*> getTextMaybe ((#peek InterpMorf, interp) ptr) + return $ Edge from to (RawInterp orth base msd) + where + getInt = fmap fromIntegral :: IO CInt -> IO Int + getText cStrIO = peekText =<< cStrIO + getTextMaybe cStrIO = cStrIO >>= \cStr -> do + if cStr == nullPtr + then return Nothing + else Just <$> peekText cStr + peekText xs = T.decodeUtf8 <$> B.packCString xs + +foreign import ccall unsafe "morfeusz_analyse" + -- InterpMorf *morfeusz_analyse(char *tekst) + c_morfeusz_analyse :: CString -> IO (Ptr (Edge RawInterp)) + +foreign import ccall unsafe "morfeusz_set_option" + -- int morfeusz_set_option(int option, int value) + c_morfeusz_set_option :: CInt -> CInt -> IO CInt + +-- | A DAG with annotated edges. +type DAG a = [Edge a] + +-- | Analyse the word and output raw Morfeusz results. +analyse :: T.Text -> DAG RawInterp +analyse word = run $ \cword -> lock $ do + _ <- setEncoding utf8 + _ <- setSpace skip_whitespace + interp_ptr <- c_morfeusz_analyse cword + when (interp_ptr == nullPtr) (fail $ "analyse: null pointer") + retrieve 0 interp_ptr + where + run = unsafePerformIO . B.useAsCString (T.encodeUtf8 word) + retrieve k ptr = do + x <- peekElemOff ptr k + if from x == -1 + then return [] + else (:) <$> return x <*> retrieve (k + 1) ptr + +-- | Translate the DAG of raw Morfeusz interpretations to +-- DAG labeled with tokens. +properDAG :: DAG RawInterp -> DAG Token +properDAG dag = + [Edge p q t | ((p, q), t) <- M.toAscList m] + where + m = M.fromListWith (<>) [((p, q), fromRaw r) | Edge p q r <- dag] + fromRaw (RawInterp o (Just b) (Just m)) = Token o [Interp b m] + fromRaw (RawInterp o _ _) = Token o [] + Token orth xs <> Token _ ys = Token orth (xs ++ ys) + +-- | Analyse the input sentence as a DAG of tokens interspersed by spaces. +-- The sentence is divided on spaces first and only individual words are +-- delivererd to Morfeusz library for morphosyntactic analysis. +asDAG :: T.Text -> [Either (DAG Token) Space] +asDAG = + flip evalState 0 . mapM updateIxs . map mkElem . T.groupBy cmp + where + cmp x y = isSpace x == isSpace y + mkElem x + | T.any isSpace x = Right x + | otherwise = Left . properDAG . analyse $ x + updateIxs (Right x) = return (Right x) + updateIxs (Left xs) = Left <$> updateDAG xs + updateDAG xs = do + n <- get + let m = maximum . map to $ xs + ys = map (shift n) xs + put (n + m) + return ys + shift k Edge{..} = Edge (from + k) (to + k) label + +-- | Retrieve all paths from the root to leaves. +toPaths :: DAG a -> [[a]] +toPaths dag = + doIt .fst . M.findMin $ m + where + m = M.fromListWith (++) [(from e, [e]) | e <- dag] + doIt p = case M.lookup p m of + Just es -> [(label e : path) | e <- es, path <- doIt (to e)] + Nothing -> [[]] + +-- | Similar to the 'asDAG' function but instead of a token DAG it returns +-- all DAG paths (using the 'toPaths' function) for each word in the +-- input sentence. +asPaths :: T.Text -> [Either [[Token]] Space] +asPaths = mapL toPaths . asDAG + +-- | Analyse the input sentence and arbitrarily choose one path +-- from the output DAG. +asPath :: T.Text -> [Either Token Space] +asPath = + let hd [] = error "asPath.head: empty list" + hd (x:xs) = x + in concatMapL hd . asPaths + +-- | Map the function over left elements. +mapL :: (a -> a') -> [Either a b] -> [Either a' b] +mapL f = + let g (Left x) = Left (f x) + g (Right y) = Right y + in map g + +-- | Concatenate left elements. +concatL :: [Either [a] b] -> [Either a b] +concatL = + let liftL (Left xs) = [Left x | x <- xs] + liftL (Right y) = [Right y] + in concat . map liftL + +-- | Map the function over left elements and concatenate results. +concatMapL :: (a -> [b]) -> [Either a c] -> [Either b c] +concatMapL f = concatL . mapL f diff --git a/NLP/Morfeusz/Lock.hs b/NLP/Morfeusz/Lock.hs new file mode 100644 --- /dev/null +++ b/NLP/Morfeusz/Lock.hs @@ -0,0 +1,15 @@ +-- | Provides a single global lock for @'IO'@ actions. Implementation borrowed +-- from the http://hackage.haskell.org/package/global-lock package. +module NLP.Morfeusz.Lock + ( lock + ) where + +import Control.Concurrent.MVar + +import NLP.Morfeusz.Lock.Internal ( get ) + +-- | Take the global lock for the duration of an @'IO'@ action. +-- +-- Two actions executed via @'lock'@ will never run simultaneously. +lock :: IO a -> IO a +lock act = get >>= flip withMVar (const act) diff --git a/NLP/Morfeusz/Lock/Internal.hs b/NLP/Morfeusz/Lock/Internal.hs new file mode 100644 --- /dev/null +++ b/NLP/Morfeusz/Lock/Internal.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | Internals of global locking. Implementation borrowed from the +-- http://hackage.haskell.org/package/global-lock package. +-- Use with caution! +module NLP.Morfeusz.Lock.Internal + ( get + ) where + +import Foreign +import Foreign.C +import Control.Monad +import Control.Concurrent.MVar + + +{- Importing c_get_global with 'unsafe' decreases locking latency by +about 50%. The C function just reads a static variable, so it's +okay to use 'unsafe'. + +c_set_global must not be imported 'unsafe' because it uses GCC +atomic-operation builtins which, in the worst case, might call a +blocking library function. -} + +{- If you are copying this file to your own Haskell project, see the +note in cbits/global.c regarding naming. -} + +foreign import ccall unsafe "hs_morfeusz_get_global" + c_get_global :: IO (Ptr ()) + +foreign import ccall "hs_morfeusz_set_global" + c_set_global :: Ptr () -> IO CInt + +set :: IO () +set = do + mv <- newMVar () + ptr <- newStablePtr mv + ret <- c_set_global (castStablePtrToPtr ptr) + when (ret == 0) $ + -- The variable was already set; our StablePtr is unused. + freeStablePtr ptr + +-- | Get the single @'MVar'@ used for global locking. +get :: IO (MVar ()) +get = do + p <- c_get_global + if p == nullPtr + then set >> get + else deRefStablePtr (castPtrToStablePtr p) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/cbits/global.c b/cbits/global.c new file mode 100644 --- /dev/null +++ b/cbits/global.c @@ -0,0 +1,28 @@ +// Atomic builtins were added in GCC 4.1. +#if !defined(__GNUC__) \ +|| (__GNUC__ < 4) \ +|| (__GNUC__ == 4 && __GNUC_MINOR__ < 1) +#error global-lock requires GCC 4.1 or later. +#endif + +static void* global = 0; + +/* +If you are copying this file to your own Haskell project, you should +probably change these function names. I suggest replacing 'morfeusz' +with your package's z-encoded name, following + +*/ + +// Imported 'unsafe' in Haskell code. Must not block! +void* hs_morfeusz_get_global(void) { + return global; +} + +int hs_morfeusz_set_global(void* new_global) { + // Set 'global', if it was previously zero. + void* old = __sync_val_compare_and_swap(&global, 0, new_global); + + // Return true iff we set it successfully. + return (old == 0); +} diff --git a/morfeusz.cabal b/morfeusz.cabal new file mode 100644 --- /dev/null +++ b/morfeusz.cabal @@ -0,0 +1,29 @@ +name: morfeusz +version: 0.3.0 +synopsis: Bindings to the morphological analyser Morfeusz +description: + The library provides bindings to the morphological analyser Morfeusz + . +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.6 +copyright: Copyright (c) 2012 IPI PAN +author: Jakub Waszczuk +maintainer: waszczuk.kuba@gmail.com +stability: experimental +category: Natural Language Processing +homepage: https://github.com/kawu/morfeusz +build-type: Simple + +library + exposed-modules: NLP.Morfeusz + other-modules: NLP.Morfeusz.Lock, NLP.Morfeusz.Lock.Internal + build-depends: base >= 4 && < 5, containers, text, bytestring, mtl + includes: morfeusz.h + extra-libraries: morfeusz + extensions: ForeignFunctionInterface + c-sources: cbits/global.c + +source-repository head + type: git + location: git://github.com/kawu/morfeusz.git