{ Модуль интерфейса с динамической библиотекой Hunspell.
  Основан на коде, который имеется во многих местах на форуме Lazarus и Github.
  Предполагается, что он может свободно использоваться кем-либо для любых целей.
 
  OlegZ 2020
}
unit ZHunSpellers;

{$mode objfpc}{$H+}

interface

uses
  Windows,
  Classes, SysUtils,
  LazUTF8;

{$Inline on}

//----------------------------------------------------------------------------------------
const
  // Имя файла DLL по умолчанию
  {$IfDef WIN32}
  cDefaultHunspellLibName = 'libhunspell-1.7_32.dll';
  {$Else}
  {$IfDef WIN64}
  cDefaultHunspellLibName = 'libhunspell-1.7_64.dll';
  {$Else}
  {$Error Bad target OS}
  {$EndIf}
  {$EndIf}

//----------------------------------------------------------------------------------------
// Обработчик исключений для ошибок в модуле
type
  EHunSpellerError = class(Exception)
  end;

//----------------------------------------------------------------------------------------
type

  { THunSpeller }

  THunSpeller = class
    private
     FDictionaryFullName: string; // полное имя файла dic загруженного словаря
     FSpeller: Pointer; // указатель на экземпляр speller'а - результат Hunspell_create
     // возвращает True, если speller готов к работе
     function GetReady: boolean; inline;
     // возвращает кодировку загруженного словаря
     function GetDictEncoding: string;
     // внутренняя процедура выполнения функций Hunspell_suggest, Hunspell_analyze и Hunspell_stem
     procedure iProcWithList(aFunc: pointer; const aWord: string; aList: TStrings);

    public
     // создание speller без загрузки словаря
     constructor Create;
     // создание speller с загрузкой словаря, файл которого задан именем aFullDictName
     // считается, что файл аффиксов (aff) находится в том же каталоге
     constructor Create(const aFullDictName: string);
     destructor Destroy; override;

     // загрузка словаря из файла aFullDictName, предыдущий словарь закрывается
     procedure OpenDictionary(const aFullDictName: string);
     // закрытие загруженного словаря
     procedure CloseDictionary;

     //----------- обертки функций DLL -----------
     // проверка слова aWord,возвращает True, если слово правильное
     function Spell(const aWord: string): boolean;
     // в списке aList возвращаются варианты неправильного слова aWord
     // если вариантов нет, то возвращается пустой список
     procedure Suggest(const aWord: string; aList: TStrings);
     // в списке aList возвращаются результаты морфологического анализа слова aWord
     procedure Analyze(const aWord: string; aList: TStrings);
     // в списке aList возвращаются варианты основы слова aWord
     procedure Stem(const aWord: string; aList: TStrings);
     // слово aWord добавляется в загруженный (run-time) словарь
     procedure Add(const aWord: string);
     // слово aWord добавляется в загруженный (run-time) словарь
     // изменяемые формы слова aWord образуются аналогично словарному слову aExample
     procedure AddWithAffix(const aWord, aExample: string);
     // слово aWord удаляется из загруженного (run-time) словаря
     procedure Remove(const aWord: string);

     property Ready: boolean read GetReady;
     property DictionaryFullName: string read FDictionaryFullName;
     property DictEncoding: string read GetDictEncoding;
  end;

//----------------------------------------------------------------------------------------
var
  DefaultDLLPath: string = ''; // путь поиска файла DLL-библиотеки
  DefaultHunspellLibName: string = cDefaultHunspellLibName; // имя файла DLL-библиотеки

// возвращает полное имя файла загруженной DLL-библиотеки
function GetDLLFullName: string; 

property DLLFullName: string read GetDLLFullName;

//****************************************************************************************
//****************************************************************************************
implementation

//----------------------------------------------------------------------------------------
// DLL Library control
//----------------------------------------------------------------------------------------
var 
  FDLLFullName: string; // полное имя файла загруженной DLL-библиотеки
  FLibHandle: THandle = NilHandle; // дескриптор DLL-библиотеки
  FAllLibProcLoaded: boolean = false; // = True, если успешно загружены адреса всех используемых функций

  // адреса необходимых функций DLL
  HS_create: pointer;
  HS_destroy: pointer;
  HS_spell: pointer;
  HS_suggest: pointer;
  HS_analyze: pointer;
  HS_stem: pointer;
  HS_free_list: pointer;
  HS_add: pointer;
  HS_add_with_affix: pointer;
  HS_remove: pointer;
  HS_get_dic_encoding: pointer;

  FSpellersCount: integer = 0; // счетчик активных speller'ов

//----------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------

// возвращает полное имя файла загруженной DLL
function GetDLLFullName: string;
begin
 Result := FDLLFullName;
end;

// внутренняя функция получения адреса экспортируемой функции по имени
// при ошибке генерируется прерывание EHunSpellerError 
function iGetProcAddr(const aFuncName: string): pointer;
begin
  Result := system.GetProcAddress(FLibHandle, aFuncName);
  if not Assigned(Result) then
    raise EHunSpellerError.CreateFmt('Failed to find functions "%s" in "%s"',
     [aFuncName, FDLLFullName]);
end;

// получение адресов всех используемых функций DLL
procedure SetupFuncVars;
begin
  HS_create := iGetProcAddr('Hunspell_create');
  HS_destroy := iGetProcAddr('Hunspell_destroy');
  HS_spell := iGetProcAddr('Hunspell_spell');
  HS_suggest := iGetProcAddr('Hunspell_suggest');
  HS_analyze := iGetProcAddr('Hunspell_analyze');
  HS_stem := iGetProcAddr('Hunspell_stem');
  HS_free_list := iGetProcAddr('Hunspell_free_list');
  HS_add := iGetProcAddr('Hunspell_add');
  HS_add_with_affix := iGetProcAddr('Hunspell_add_with_affix');
  HS_remove := iGetProcAddr('Hunspell_remove');
  HS_get_dic_encoding := iGetProcAddr('Hunspell_get_dic_encoding');
  FAllLibProcLoaded := true;
end;

// загрузка DLL
procedure OpenLib;
const
  cBufLen = 1024;
var
  s: string;
begin
  s := DefaultDLLPath + DefaultHunspellLibName;
  FLibHandle := system.LoadLibrary(s);
  if FLibHandle = NilHandle then
    raise EHunSpellerError.CreateFmt('Failed to load library: %s', [FDLLFullName]);

  SetLength(s, cBufLen);
  GetModuleFileName(FLibHandle, @s[1], cBufLen);
  SetLength(s, strlen(@s[1]));
  FDLLFullName := WinCPToUTF8(s);
  SetupFuncVars;
end;

// выгрузка DLL
procedure CloseLib;
begin
  if (FLibHandle <> NilHandle) then begin
    system.FreeLibrary(FLibHandle);
    FLibHandle := NilHandle;
    FAllLibProcLoaded := false;
  end;
end;

//----------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------

{ THunSpeller }

// возвращает True, если экземпляр speller'а готов к работе
function THunSpeller.GetReady: boolean;
begin
  Result := (FLibHandle <> NilHandle) // DLL загружена
       and FAllLibProcLoaded // все используемые функции загружены
       and (FSpeller <> nil); // speller создан
end;

//----------------------------------------------------------------------------------------
// возвращает тип кодировки файла словаря
function THunSpeller.GetDictEncoding: string;
//hunspell.h -> char* Hunspell_get_dic_encoding(Hunhandle* pHunspell);
type
  THSFunc_get_dic_encoding = function(spell: Pointer): PChar; cdecl;
var
  p: pchar;
begin
  if not Ready then exit('Speller is not ready');

  p := THSFunc_get_dic_encoding(HS_get_dic_encoding)(FSpeller);
  if p = nil then exit('Encoding string not found');

  SetLength(Result, strlen(p));
  Move(p^, Result[1], strlen(p));
end;

//----------------------------------------------------------------------------------------
// создание экземпляра speller'а без открытия словаря
constructor THunSpeller.Create;
begin
  if FLibHandle = NilHandle then
    OpenLib;
end;

//----------------------------------------------------------------------------------------
// создание экземпляра speller'а с открытием словаря
constructor THunSpeller.Create(const aFullDictName: string);
begin
  if FLibHandle = NilHandle then
   OpenLib;
  OpenDictionary(aFullDictName);
end;

//----------------------------------------------------------------------------------------
destructor THunSpeller.Destroy;
begin
  CloseDictionary;
  inherited Destroy;
end;

//----------------------------------------------------------------------------------------
// открытие словаря из файла aFullDictName, 
// ранее открытый словарь предварительно закрывается
procedure THunSpeller.OpenDictionary(const aFullDictName: string);
//hunspell.h -> Hunhandle* Hunspell_create(const char* affpath, const char* dpath);
type
  THSFunc_create = function(aff_file: PChar; dict_file: PChar): Pointer; cdecl;
var
  FullAffName : string;
begin
  CloseDictionary;
  FDictionaryFullName := aFullDictName;
  FullAffName := UTF8Copy(aFullDictName, 1, UTF8Length(aFullDictName) - 3) + 'aff';
  FSpeller := THSFunc_create(HS_create)(PChar(UTF8ToWinCP(FullAffName)), PChar(UTF8ToWinCP(aFullDictName)));
  if FSpeller = nil then
    raise EHunSpellerError.CreateFmt('Failed to open Dictionary "%s"', [aFullDictName]);

  inc(FSpellersCount);
end;

//----------------------------------------------------------------------------------------
// закрытие словаря
procedure THunSpeller.CloseDictionary;
//hunspell.h -> Hunspell_destroy(Hunhandle* pHunspell);
type
  THSFunc_destroy = procedure(spell: Pointer); cdecl;
begin
  if Ready then begin
    THSFunc_destroy(HS_destroy)(FSpeller);
    FSpeller := nil;
    dec(FSpellersCount);
  end;
end;

//----------------------------------------------------------------------------------------
// проверка слова aWord,возвращает True, если слово правильное
function THunSpeller.Spell(const aWord: string): boolean;
//hunspell.h -> int Hunspell_spell(Hunhandle* pHunspell, const char* );
type
  THSFunc_spell = function(spell: Pointer; word: PChar): Boolean; cdecl;
begin
  if Ready then
    Result := THSFunc_spell(HS_spell)(FSpeller, PChar(aWord))
  else
    Result := false;
end;

//----------------------------------------------------------------------------------------
// приватная процедура вызова функций DLL, которые возвращают результат в виде списка слов:
// Hunspell_suggest, Hunspell_analyze и Hunspell_stem
procedure THunSpeller.iProcWithList(aFunc: pointer; const aWord: string; aList: TStrings);
type
  THSFuncWithList = function(spell: Pointer; out slst: PPChar; word: PChar): Integer; cdecl;
  //hunspell.h -> void Hunspell_free_list(Hunhandle* pHunspell, char*** slst, int n);
  THSFunc_free_list = procedure(spell: Pointer; var slst: PPChar; n: integer); cdecl;
var
  i, len: Integer;
  SugList, Words: PPChar;
begin
  aList.Clear;
  if not Ready then
    exit;

  try
    len := THSFuncWithList(aFunc)(FSpeller, SugList, PChar(aWord));
    Words := SugList;
    for i := 1 to len do begin
      aList.Add(PChar(Words^));
      Inc(Words);
    end;
  finally
    // освобождение списка слов
    THSFunc_free_list(HS_free_list)(FSpeller, SugList, len);
  end;
end;

//----------------------------------------------------------------------------------------
// в списке aList возвращаются варианты неправильного слова aWord
// если вариантов нет, то возвращается пустой список
procedure THunSpeller.Suggest(const aWord: string; aList: TStrings);
//hunspell.h -> int Hunspell_suggest(Hunhandle* pHunspell, char*** slst, const char* word);
begin
  iProcWithList(HS_suggest, aWord, aList);
end;

//----------------------------------------------------------------------------------------
// в списке aList возвращаются результаты морфологического анализа слова aWord
procedure THunSpeller.Analyze(const aWord: string; aList: TStrings);
//hunspell.h -> int Hunspell_analyze(Hunhandle* pHunspell, char*** slst, const char* word);
begin
  iProcWithList(HS_analyze, aWord, aList);
end;

//----------------------------------------------------------------------------------------
// в списке aList возвращаются варианты основы слова aWord
procedure THunSpeller.Stem(const aWord: string; aList: TStrings);
//hunspell.h -> int Hunspell_stem(Hunhandle* pHunspell, char*** slst, const char* word);
begin
  iProcWithList(HS_stem, aWord, aList);
end;

//----------------------------------------------------------------------------------------
// слово aWord добавляется в загруженный (run-time) словарь
procedure THunSpeller.Add(const aWord: string);
//hunspell.h -> int Hunspell_add(Hunhandle* pHunspell, const char* word);
type
  THSFunc_add = function(spell: Pointer; word: PChar): Integer; cdecl;
begin
  if Ready then
    THSFunc_add(HS_add)(FSpeller, Pchar(aWord));
end;

//----------------------------------------------------------------------------------------
// слово aWord добавляется в загруженный (run-time) словарь
// изменяемые формы слова aWord образуются аналогично словарному слову aExample
procedure THunSpeller.AddWithAffix(const aWord, aExample: string);
//hunspell.h -> int Hunspell_add_with_affix(Hunhandle* pHunspell, const char* word, const char* example);
type
  THSFunc_add_with_affix = function(spell: Pointer; word: PChar; example: PChar): Integer; cdecl;
begin
  if Ready then
    THSFunc_add_with_affix(HS_add_with_affix)(FSpeller, PChar(aWord), PChar(aExample));
end;

//----------------------------------------------------------------------------------------
// слово aWord удаляется из загруженного (run-time) словаря
procedure THunSpeller.Remove(const aWord: string);
//hunspell.h -> int Hunspell_remove(Hunhandle* pHunspell, const char* word);
type
  THSFunc_remove = function(spell: Pointer; word: PChar): Integer; cdecl;
begin
  if Ready then
    THSFunc_remove(HS_remove)(FSpeller, Pchar(aWord));
end;

//----------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------
//----------------------------------------------------------------------------------------
finalization
  // выгрузка DLL при завершении работы программы
  CloseLib;
  // проверка завершения всех экземпляров speller'ов
  if FSpellersCount > 0 then
    raise EHunSpellerError.CreateFmt('Not disposed spellers: %d', [FSpellersCount]);
end.