{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 qualified Control.Concurrent.Async as A
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
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 { Aspell -> ProcessHandle
aspellProcessHandle :: P.ProcessHandle
, Aspell -> Handle
aspellStdin :: Handle
, Aspell -> Handle
aspellStdout :: Handle
, Aspell -> Text
aspellIdentification :: T.Text
, Aspell -> MVar ()
aspellLock :: MVar ()
}
instance Show Aspell where
show :: Aspell -> String
show Aspell
as = [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"Aspell<"
, Text -> String
T.unpack (Aspell -> Text
aspellIdentification Aspell
as)
, String
">"
]
data AspellResponse =
AllCorrect
| Mistakes [Mistake]
deriving (AspellResponse -> AspellResponse -> Bool
(AspellResponse -> AspellResponse -> Bool)
-> (AspellResponse -> AspellResponse -> Bool) -> Eq AspellResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AspellResponse -> AspellResponse -> Bool
$c/= :: AspellResponse -> AspellResponse -> Bool
== :: AspellResponse -> AspellResponse -> Bool
$c== :: AspellResponse -> AspellResponse -> Bool
Eq, Int -> AspellResponse -> ShowS
[AspellResponse] -> ShowS
AspellResponse -> String
(Int -> AspellResponse -> ShowS)
-> (AspellResponse -> String)
-> ([AspellResponse] -> ShowS)
-> Show AspellResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AspellResponse] -> ShowS
$cshowList :: [AspellResponse] -> ShowS
show :: AspellResponse -> String
$cshow :: AspellResponse -> String
showsPrec :: Int -> AspellResponse -> ShowS
$cshowsPrec :: Int -> AspellResponse -> ShowS
Show)
data Mistake =
Mistake { Mistake -> Text
mistakeWord :: T.Text
, Mistake -> Int
mistakeNearMisses :: Int
, Mistake -> Int
mistakeOffset :: Int
, Mistake -> [Text]
mistakeAlternatives :: [T.Text]
}
deriving (Int -> Mistake -> ShowS
[Mistake] -> ShowS
Mistake -> String
(Int -> Mistake -> ShowS)
-> (Mistake -> String) -> ([Mistake] -> ShowS) -> Show Mistake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mistake] -> ShowS
$cshowList :: [Mistake] -> ShowS
show :: Mistake -> String
$cshow :: Mistake -> String
showsPrec :: Int -> Mistake -> ShowS
$cshowsPrec :: Int -> Mistake -> ShowS
Show, Mistake -> Mistake -> Bool
(Mistake -> Mistake -> Bool)
-> (Mistake -> Mistake -> Bool) -> Eq Mistake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mistake -> Mistake -> Bool
$c/= :: Mistake -> Mistake -> Bool
== :: Mistake -> Mistake -> Bool
$c== :: Mistake -> Mistake -> Bool
Eq)
data AspellOption =
UseDictionary T.Text
| RawArg T.Text
deriving (Int -> AspellOption -> ShowS
[AspellOption] -> ShowS
AspellOption -> String
(Int -> AspellOption -> ShowS)
-> (AspellOption -> String)
-> ([AspellOption] -> ShowS)
-> Show AspellOption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AspellOption] -> ShowS
$cshowList :: [AspellOption] -> ShowS
show :: AspellOption -> String
$cshow :: AspellOption -> String
showsPrec :: Int -> AspellOption -> ShowS
$cshowsPrec :: Int -> AspellOption -> ShowS
Show, AspellOption -> AspellOption -> Bool
(AspellOption -> AspellOption -> Bool)
-> (AspellOption -> AspellOption -> Bool) -> Eq AspellOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AspellOption -> AspellOption -> Bool
$c/= :: AspellOption -> AspellOption -> Bool
== :: AspellOption -> AspellOption -> Bool
$c== :: AspellOption -> AspellOption -> Bool
Eq)
startAspell :: [AspellOption] -> IO (Either String Aspell)
startAspell :: [AspellOption] -> IO (Either String Aspell)
startAspell [AspellOption]
options = do
Maybe String
optResult <- [AspellOption] -> IO (Maybe String)
checkOptions [AspellOption]
options
case Maybe String
optResult of
Just String
e -> Either String Aspell -> IO (Either String Aspell)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Aspell -> IO (Either String Aspell))
-> Either String Aspell -> IO (Either String Aspell)
forall a b. (a -> b) -> a -> b
$ String -> Either String Aspell
forall a b. a -> Either a b
Left String
e
Maybe String
Nothing -> IO Aspell -> IO (Either String Aspell)
forall a. IO a -> IO (Either String a)
tryConvert (IO Aspell -> IO (Either String Aspell))
-> IO Aspell -> IO (Either String Aspell)
forall a b. (a -> b) -> a -> b
$ do
let proc :: CreateProcess
proc = (String -> [String] -> CreateProcess
P.proc String
aspellCommand (String
"-a" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ AspellOption -> [String]
optionToArgs (AspellOption -> [String]) -> [AspellOption] -> [[String]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AspellOption]
options)))
{ std_in :: StdStream
P.std_in = StdStream
P.CreatePipe
, std_out :: StdStream
P.std_out = StdStream
P.CreatePipe
, std_err :: StdStream
P.std_err = StdStream
P.CreatePipe
}
(Just Handle
inH, Just Handle
outH, Just Handle
errH, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
P.createProcess CreateProcess
proc
Async Text
errorAsync <- IO Text -> IO (Async Text)
forall a. IO a -> IO (Async a)
A.async (Handle -> IO Text
T.hGetLine Handle
errH)
Either SomeException Text
result <- IO Text -> IO (Either SomeException Text)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (Handle -> IO Text
T.hGetLine Handle
outH) :: IO (Either E.SomeException T.Text)
case Either SomeException Text
result of
Left{} -> do
Text
e <- Async Text -> IO Text
forall a. Async a -> IO a
A.wait Async Text
errorAsync
String -> IO Aspell
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Error starting aspell: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
e)
Right Text
ident -> do
Async Text -> IO ()
forall a. Async a -> IO ()
A.cancel Async Text
errorAsync
case Text -> Bool
validIdent Text
ident of
Bool
False -> String -> IO Aspell
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unexpected identification string: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ident)
Bool
True -> do
MVar ()
mv <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
let as :: Aspell
as = Aspell :: ProcessHandle -> Handle -> Handle -> Text -> MVar () -> Aspell
Aspell { aspellProcessHandle :: ProcessHandle
aspellProcessHandle = ProcessHandle
ph
, aspellStdin :: Handle
aspellStdin = Handle
inH
, aspellStdout :: Handle
aspellStdout = Handle
outH
, aspellIdentification :: Text
aspellIdentification = Text
ident
, aspellLock :: MVar ()
aspellLock = MVar ()
mv
}
Handle -> Text -> IO ()
T.hPutStrLn Handle
inH Text
"!"
Aspell -> IO Aspell
forall (m :: * -> *) a. Monad m => a -> m a
return Aspell
as
validIdent :: T.Text -> Bool
validIdent :: Text -> Bool
validIdent Text
s =
Text
"@(#) International Ispell Version" Text -> Text -> Bool
`T.isPrefixOf` Text
s Bool -> Bool -> Bool
&&
Text
"but really Aspell" Text -> Text -> Bool
`T.isInfixOf` Text
s
checkOptions :: [AspellOption] -> IO (Maybe String)
checkOptions :: [AspellOption] -> IO (Maybe String)
checkOptions [] = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
checkOptions (AspellOption
o:[AspellOption]
os) = do
Maybe String
result <- AspellOption -> IO (Maybe String)
checkOption AspellOption
o
case Maybe String
result of
Maybe String
Nothing -> [AspellOption] -> IO (Maybe String)
checkOptions [AspellOption]
os
Just String
msg -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
msg
aspellCommand :: String
aspellCommand :: String
aspellCommand = String
"aspell"
checkOption :: AspellOption -> IO (Maybe String)
checkOption :: AspellOption -> IO (Maybe String)
checkOption (RawArg {}) = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
checkOption (UseDictionary Text
d) = do
Either String [Text]
dictListResult <- IO (Either String [Text])
aspellDictionaries
case Either String [Text]
dictListResult of
Left String
msg -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
msg
Right [Text]
dictList ->
case Text
d Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
dictList of
Bool
True -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Bool
False -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Requested dictionary " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
d String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not installed"
aspellDictionaries :: IO (Either String [T.Text])
aspellDictionaries :: IO (Either String [Text])
aspellDictionaries =
IO [Text] -> IO (Either String [Text])
forall a. IO a -> IO (Either String a)
tryConvert (IO [Text] -> IO (Either String [Text]))
-> IO [Text] -> IO (Either String [Text])
forall a b. (a -> b) -> a -> b
$
(String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([String] -> [Text]) -> (String -> [String]) -> String -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines (String -> [Text]) -> IO String -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
P.readProcess String
aspellCommand [String
"dicts"] String
""
optionToArgs :: AspellOption -> [String]
optionToArgs :: AspellOption -> [String]
optionToArgs (UseDictionary Text
d) = [String
"-d", Text -> String
T.unpack Text
d]
optionToArgs (RawArg Text
val) = [Text -> String
T.unpack Text
val]
stopAspell :: Aspell -> IO ()
stopAspell :: Aspell -> IO ()
stopAspell = ProcessHandle -> IO ()
P.terminateProcess (ProcessHandle -> IO ())
-> (Aspell -> ProcessHandle) -> Aspell -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Aspell -> ProcessHandle
aspellProcessHandle
askAspell :: Aspell -> T.Text -> IO [AspellResponse]
askAspell :: Aspell -> Text -> IO [AspellResponse]
askAspell Aspell
as Text
t = MVar () -> (() -> IO [AspellResponse]) -> IO [AspellResponse]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Aspell -> MVar ()
aspellLock Aspell
as) ((() -> IO [AspellResponse]) -> IO [AspellResponse])
-> (() -> IO [AspellResponse]) -> IO [AspellResponse]
forall a b. (a -> b) -> a -> b
$ IO [AspellResponse] -> () -> IO [AspellResponse]
forall a b. a -> b -> a
const (IO [AspellResponse] -> () -> IO [AspellResponse])
-> IO [AspellResponse] -> () -> IO [AspellResponse]
forall a b. (a -> b) -> a -> b
$ do
[Text] -> (Text -> IO AspellResponse) -> IO [AspellResponse]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Text -> [Text]
T.lines Text
t) ((Text -> IO AspellResponse) -> IO [AspellResponse])
-> (Text -> IO AspellResponse) -> IO [AspellResponse]
forall a b. (a -> b) -> a -> b
$ \Text
theLine -> do
Handle -> Text -> IO ()
T.hPutStrLn (Aspell -> Handle
aspellStdin Aspell
as) (Text
"^" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
theLine)
Handle -> IO ()
hFlush (Aspell -> Handle
aspellStdin Aspell
as)
[Text]
resultLines <- Handle -> (Text -> Bool) -> IO [Text]
readLinesUntil (Aspell -> Handle
aspellStdout Aspell
as) Text -> Bool
T.null
case [Text]
resultLines of
[] -> AspellResponse -> IO AspellResponse
forall (m :: * -> *) a. Monad m => a -> m a
return AspellResponse
AllCorrect
[Text]
_ -> AspellResponse -> IO AspellResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (AspellResponse -> IO AspellResponse)
-> AspellResponse -> IO AspellResponse
forall a b. (a -> b) -> a -> b
$ [Mistake] -> AspellResponse
Mistakes ([Mistake] -> AspellResponse) -> [Mistake] -> AspellResponse
forall a b. (a -> b) -> a -> b
$ Text -> Mistake
parseMistake (Text -> Mistake) -> [Text] -> [Mistake]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
resultLines
parseMistake :: T.Text -> Mistake
parseMistake :: Text -> Mistake
parseMistake Text
t
| Text
"&" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text -> Mistake
parseWithAlternatives Text
t
| Text
"#" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text -> Mistake
parseWithoutAlternatives Text
t
parseWithAlternatives :: T.Text -> Mistake
parseWithAlternatives :: Text -> Mistake
parseWithAlternatives Text
t =
let (Text
header, Text
altsWithColon) = Text -> Text -> (Text, Text)
T.breakOn Text
": " Text
t
altsStr :: Text
altsStr = Int -> Text -> Text
T.drop Int
2 Text
altsWithColon
[Text
"&", Text
orig, Text
nearMissesStr, Text
offsetStr] = Text -> [Text]
T.words Text
header
alts :: [Text]
alts = Text -> Text -> [Text]
T.splitOn Text
", " Text
altsStr
offset :: Int
offset = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
offsetStr
nearMisses :: Int
nearMisses = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
nearMissesStr
in Mistake :: Text -> Int -> Int -> [Text] -> Mistake
Mistake { mistakeWord :: Text
mistakeWord = Text
orig
, mistakeNearMisses :: Int
mistakeNearMisses = Int
nearMisses
, mistakeOffset :: Int
mistakeOffset = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, mistakeAlternatives :: [Text]
mistakeAlternatives = [Text]
alts
}
parseWithoutAlternatives :: T.Text -> Mistake
parseWithoutAlternatives :: Text -> Mistake
parseWithoutAlternatives Text
t =
let [Text
"#", Text
orig, Text
offsetStr] = Text -> [Text]
T.words Text
t
offset :: Int
offset = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
offsetStr
in Mistake :: Text -> Int -> Int -> [Text] -> Mistake
Mistake { mistakeWord :: Text
mistakeWord = Text
orig
, mistakeNearMisses :: Int
mistakeNearMisses = Int
0
, mistakeOffset :: Int
mistakeOffset = Int
offset
, mistakeAlternatives :: [Text]
mistakeAlternatives = []
}
readLinesUntil :: Handle -> (T.Text -> Bool) -> IO [T.Text]
readLinesUntil :: Handle -> (Text -> Bool) -> IO [Text]
readLinesUntil Handle
h Text -> Bool
f = do
Text
line <- Handle -> IO Text
T.hGetLine Handle
h
case Text -> Bool
f Text
line of
Bool
True -> [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Bool
False -> do
[Text]
rest <- Handle -> (Text -> Bool) -> IO [Text]
readLinesUntil Handle
h Text -> Bool
f
[Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ Text
line Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest
tryConvert :: IO a -> IO (Either String a)
tryConvert :: IO a -> IO (Either String a)
tryConvert IO a
act = do
Either SomeException a
result <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try IO a
act
Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ (SomeException -> Either String a)
-> (a -> Either String a)
-> Either SomeException a
-> Either String a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (SomeException -> String) -> SomeException -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
showException) a -> Either String a
forall a b. b -> Either a b
Right Either SomeException a
result
showException :: E.SomeException -> String
showException :: SomeException -> String
showException = SomeException -> String
forall a. Show a => a -> String
show