module NLP.Polh.Binary
( savePolh
, loadPolh
, PolhM
, runPolh
, index
, withKey
, lookup
) where
import Prelude hiding (lookup)
import Control.Exception (try, SomeException)
import Control.Monad (when, guard)
import Control.Applicative ((<$>))
import Control.Monad.Reader (ReaderT (..), ask, lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
import System.FilePath ((</>))
import System.Directory ( getDirectoryContents, createDirectoryIfMissing
, createDirectory, doesDirectoryExist )
import Data.Maybe (catMaybes)
import Data.Monoid (mappend, mconcat)
import Data.Binary (encodeFile, decodeFile)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import NLP.Polh.Types
import qualified NLP.Polh.Util as Util
entryDir :: String
entryDir = "entries"
formMapFile :: String
formMapFile = "forms.bin"
type Key = T.Text
loadContents :: FilePath -> IO [FilePath]
loadContents path = do
xs <- getDirectoryContents path
return [x | x <- xs, x /= ".", x /= ".."]
emptyDirectory :: FilePath -> IO Bool
emptyDirectory path = null <$> loadContents path
saveLexEntry :: FilePath -> LexEntry -> IO ()
saveLexEntry path x =
let lexPath = T.unpack . lexId
in encodeFile (path </> lexPath x) x
savePolh :: FilePath -> Polh -> IO ()
savePolh path xs = do
createDirectoryIfMissing True path
isEmpty <- emptyDirectory path
when (not isEmpty) $ do
error $ "savePolh: directory " ++ path ++ " is not empty"
let lexPath = path </> entryDir
createDirectory lexPath
formMap' <- mconcat <$> mapM (saveLex lexPath) xs
encodeFile (path </> formMapFile) formMap'
where
saveLex lexPath x = do
saveLexEntry lexPath x
return $ lexMap x
lexMap lexEntry = M.fromListWith mappend
[ (x, S.singleton key)
| x <- Util.allForms lexEntry ]
where
key = lexId lexEntry
maybeErr :: IO a -> IO (Maybe a)
maybeErr io = do
r <- try io
case r of
Left (_e :: SomeException) -> return Nothing
Right x -> return (Just x)
maybeT :: Monad m => Maybe a -> MaybeT m a
maybeT = MaybeT . return
maybeErrT :: IO a -> MaybeT IO a
maybeErrT io = do
r <- lift (maybeErr io)
maybeT r
loadLexEntry :: FilePath -> Key -> IO (Maybe LexEntry)
loadLexEntry path key = do
maybeErr $ decodeFile (path </> T.unpack key)
data MemData = MemData
{ polhPath :: FilePath
, formMap :: M.Map T.Text (S.Set Key) }
newtype PolhM a = PolhM (ReaderT MemData IO a)
deriving (Functor, Monad)
entryPath :: MemData -> FilePath
entryPath = (</> entryDir) . polhPath
index :: PolhM [Key]
index = PolhM $ do
path <- entryPath <$> ask
map T.pack <$> lift (loadContents path)
withKey :: Key -> PolhM (Maybe LexEntry)
withKey key = PolhM $ do
path <- entryPath <$> ask
lift . unsafeInterleaveIO $ loadLexEntry path key
lookup :: T.Text -> PolhM [LexEntry]
lookup x = do
fm <- PolhM $ formMap <$> ask
keys <- return $ case M.lookup x fm of
Nothing -> []
Just xs -> S.toList xs
catMaybes <$> mapM withKey keys
runPolh :: FilePath -> PolhM a -> Maybe a
runPolh path (PolhM m) = unsafePerformIO . runMaybeT $ do
formMap' <- maybeErrT $ decodeFile (path </> formMapFile)
doesExist <- lift $ doesDirectoryExist (path </> entryDir)
guard doesExist
lift $ runReaderT m (MemData path formMap')
loadPolh :: FilePath -> Maybe Polh
loadPolh path = runPolh path $ do
keys <- index
catMaybes <$> mapM withKey keys