module Text.Aspell
( Aspell
, AspellResponse(..)
, Mistake(..)
, AspellOption(..)
, startAspell
, stopAspell
, askAspell
, aspellIdentification
, aspellDictionaries
)
where
import qualified Control.Exception as E
import Control.Monad (forM, when, void)
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.MVar (takeMVar, newEmptyMVar, putMVar)
import Data.Monoid ((<>))
import Data.Maybe (fromJust)
import Text.Read (readMaybe)
import System.IO (Handle, hFlush)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified System.Process as P
data Aspell =
Aspell { aspellProcessHandle :: P.ProcessHandle
, aspellStdin :: Handle
, aspellStdout :: Handle
, aspellIdentification :: T.Text
}
instance Show Aspell where
show as = mconcat [ "Aspell<"
, T.unpack (aspellIdentification as)
, ">"
]
data AspellResponse =
AllCorrect
| Mistakes [Mistake]
deriving (Eq, Show)
data Mistake =
Mistake { mistakeWord :: T.Text
, mistakeNearMisses :: Int
, mistakeOffset :: Int
, mistakeAlternatives :: [T.Text]
}
deriving (Show, Eq)
data AspellOption =
UseDictionary T.Text
deriving (Show, Eq)
startAspell :: [AspellOption] -> IO (Either String Aspell)
startAspell options = do
optResult <- checkOptions options
case optResult of
Just e -> return $ Left e
Nothing -> tryConvert $ do
let proc = (P.proc aspellCommand ("-a" : (concat $ optionToArgs <$> options)))
{ P.std_in = P.CreatePipe
, P.std_out = P.CreatePipe
, P.std_err = P.CreatePipe
}
(Just inH, Just outH, Just errH, ph) <- P.createProcess proc
initialResult <- newEmptyMVar
void $ forkIO $ do
identResult <- E.try $ T.hGetLine outH
case identResult of
Left (_::E.SomeException) -> return ()
Right ident -> putMVar initialResult $ Right ident
errThread <- forkIO $ do
err <- T.hGetLine errH
putMVar initialResult $ Left err
status <- takeMVar initialResult
case status of
Left e -> error $ "Error starting aspell: " <> show e
Right ident -> do
killThread errThread
case validIdent ident of
False -> error $ "Unexpected identification string: " <> show ident
True -> do
let as = Aspell { aspellProcessHandle = ph
, aspellStdin = inH
, aspellStdout = outH
, aspellIdentification = ident
}
T.hPutStrLn inH "!"
return as
validIdent :: T.Text -> Bool
validIdent s =
"@(#) International Ispell Version" `T.isPrefixOf` s &&
"but really Aspell" `T.isInfixOf` s
checkOptions :: [AspellOption] -> IO (Maybe String)
checkOptions [] = return Nothing
checkOptions (o:os) = do
result <- checkOption o
case result of
Nothing -> checkOptions os
Just msg -> return $ Just msg
aspellCommand :: String
aspellCommand = "aspell"
checkOption :: AspellOption -> IO (Maybe String)
checkOption (UseDictionary d) = do
dictListResult <- aspellDictionaries
case dictListResult of
Left msg -> return $ Just msg
Right dictList ->
case d `elem` dictList of
True -> return Nothing
False -> return $ Just $ "Requested dictionary " <> show d <> " is not installed"
aspellDictionaries :: IO (Either String [T.Text])
aspellDictionaries =
tryConvert $
(T.pack <$>) <$> lines <$> P.readProcess aspellCommand ["dicts"] ""
optionToArgs :: AspellOption -> [String]
optionToArgs (UseDictionary d) = ["-d", T.unpack d]
stopAspell :: Aspell -> IO ()
stopAspell = P.terminateProcess . aspellProcessHandle
askAspell :: Aspell -> T.Text -> IO [AspellResponse]
askAspell as t = do
forM (T.lines t) $ \theLine -> do
T.hPutStrLn (aspellStdin as) ("^" <> theLine)
hFlush (aspellStdin as)
resultLines <- readLinesUntil (aspellStdout as) T.null
case resultLines of
[] -> return AllCorrect
_ -> return $ Mistakes $ parseMistake <$> resultLines
parseMistake :: T.Text -> Mistake
parseMistake t
| "&" `T.isPrefixOf` t = parseWithAlternatives t
| "#" `T.isPrefixOf` t = parseWithoutAlternatives t
parseWithAlternatives :: T.Text -> Mistake
parseWithAlternatives t =
let (header, altsWithColon) = T.breakOn ": " t
altsStr = T.drop 2 altsWithColon
["&", orig, nearMissesStr, offsetStr] = T.words header
alts = T.splitOn ", " altsStr
offset = fromJust $ readMaybe $ T.unpack offsetStr
nearMisses = fromJust $ readMaybe $ T.unpack nearMissesStr
in Mistake { mistakeWord = orig
, mistakeNearMisses = nearMisses
, mistakeOffset = offset 1
, mistakeAlternatives = alts
}
parseWithoutAlternatives :: T.Text -> Mistake
parseWithoutAlternatives t =
let ["#", orig, offsetStr] = T.words t
offset = fromJust $ readMaybe $ T.unpack offsetStr
in Mistake { mistakeWord = orig
, mistakeNearMisses = 0
, mistakeOffset = offset
, mistakeAlternatives = []
}
readLinesUntil :: Handle -> (T.Text -> Bool) -> IO [T.Text]
readLinesUntil h f = do
line <- T.hGetLine h
case f line of
True -> return []
False -> do
rest <- readLinesUntil h f
return $ line : rest
tryConvert :: IO a -> IO (Either String a)
tryConvert act = do
result <- E.try act
return $ either (Left . showException) Right result
showException :: E.SomeException -> String
showException = show