module Text.Aspell
( Aspell
, AspellResponse(..)
, Mistake(..)
, AspellOption(..)
, startAspell
, stopAspell
, askAspell
, aspellIdentification
)
where
import qualified Control.Exception as E
import Control.Monad (forM)
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
let proc = (P.proc "aspell" ("-a" : (concat $ optionToArgs <$> options)))
{ P.std_in = P.CreatePipe
, P.std_out = P.CreatePipe
, P.std_err = P.NoStream
}
result <- E.try $ P.createProcess proc
case result of
Left (e::E.SomeException) -> return $ Left $ show e
Right (Just inH, Just outH, Nothing, ph) -> do
identResult <- E.try $ T.hGetLine outH
case identResult of
Left (e::E.SomeException) -> return $ Left $ show e
Right ident -> do
let as = Aspell { aspellProcessHandle = ph
, aspellStdin = inH
, aspellStdout = outH
, aspellIdentification = ident
}
T.hPutStrLn inH "!"
return $ Right as
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