{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | A pipe-based interface to Aspell.
--
-- This interface is beneficial when dynamic linking against the Aspell
-- library would be undesirable, e.g., for binary portability reasons.
--
-- This implementation is based on the description of the Aspell pipe
-- protocol at
--
-- http://aspell.net/man-html/Through-A-Pipe.html
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

-- | A handle to a running Aspell instance.
data Aspell =
    Aspell { Aspell -> ProcessHandle
aspellProcessHandle  :: P.ProcessHandle
           , Aspell -> Handle
aspellStdin          :: Handle
           , Aspell -> Handle
aspellStdout         :: Handle
           , Aspell -> Text
aspellIdentification :: T.Text -- ^ startup-reported version string
           , 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
">"
                      ]

-- | The kind of responses we can get from Aspell.
data AspellResponse =
    AllCorrect
    -- ^ The input had no spelling mistakes.
    | Mistakes [Mistake]
    -- ^ The input had the specified mistakes.
    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)

-- | A spelling mistake.
data Mistake =
    Mistake { Mistake -> Text
mistakeWord :: T.Text
            -- ^ The original word in misspelled form.
            , Mistake -> Int
mistakeNearMisses :: Int
            -- ^ The number of alternative correct spellings that were
            -- counted.
            , Mistake -> Int
mistakeOffset :: Int
            -- ^ The offset, starting at zero, in the original input
            -- where this misspelling occurred.
            , Mistake -> [Text]
mistakeAlternatives :: [T.Text]
            -- ^ The correct spelling alternatives.
            }
            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)

-- | An Aspell option.
data AspellOption =
    UseDictionary T.Text
    -- ^ Use the specified dictionary (see @aspell -d@).
    | RawArg T.Text
    -- ^ Provide a command-line argument directly to @aspell@.
    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)

-- | Start Aspell with the specified options. Returns either an error
-- message on failure or an 'Aspell' handle on success.
--
-- Any 'RawArg's provided in the option list are provided to @aspell@ as
-- command-line arguments in the order provided.
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)

            -- If startup is unsuccessful, stdout will close without output.
            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
                    -- Now that aspell has started and we got an
                    -- identification string, we need to make sure it
                    -- looks legitimate before we proceed.
                    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
                                            }

                            -- Enable terse mode with aspell to improve performance.
                            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
    -- Get the list of installed dictionaries and check whether the
    -- desired dictionary is included.
    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"

-- | Obtain the list of installed Aspell dictionaries.
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]

-- | Stop a running Aspell instance.
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

-- | Submit input text to Aspell for spell-checking. The input text may
-- contain multiple lines. This returns an 'AspellResponse' for each
-- line.
--
-- This function is thread-safe and will block until other callers
-- finish.
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
    -- Send the user's input. Prefix with "^" to ensure that the line is
    -- checked even if it contains metacharacters.
    [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)

        -- Read lines until we get an empty one, which indicates that aspell
        -- is done with the request.
        [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
               -- Aspell's offset starts at 1 here because of the "^"
               -- we included in the input. Here we adjust the offset
               -- so that it's relative to the beginning of the user's
               -- input, not our protocol input.
               , 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