- 追加された行はこの色です。
- 削除された行はこの色です。
*[[Haskell:http://www.haskell.org/]] [#r7b07a76]
#ref(http://upload.wikimedia.org/wikipedia/commons/thumb/1/1c/Haskell-Logo.svg/200px-Haskell-Logo.svg.png,right,around,nolink,Haskell)
&color(White,#5F2F2F){ ''◆CONTENTS◆'' };&br;
#contents
*Summary [#j02438c3]
Haskell は非正格な純粋関数型プログラミング言語です．~
-[http://www.haskell.org/ Haskell]
-[http://www.haskell.org/haskellwiki/Haskell HaskellWiki]
-[http://www.haskell.org/pipermail/libraries/ The Libraries Archives]
-[[HaskellJP wiki:http://wiki.haskell.jp/]]
-[[Learn You a Haskell for Great Good!:http://learnyouahaskell.com/]]
-https://github.com/yallop/haskell2014-papers
-http://www.reddit.com/r/haskell/
-[http://d.hatena.ne.jp/kazu-yamamoto/touch/20140206/1391666962 Real World Haskell の古いところ]
-[[ゆるふわHaskell (Light & Airy Haskell):http://kzfm.github.io/laskell/]]
-http://maoe.hatenadiary.jp/archive/category/Haskell
-[[本物のプログラマはHaskellを使う:http://itpro.nikkeibp.co.jp/article/COLUMN/20060915/248215/]]
-[[Haskellで文字列を UTF-32 ⇔UTF-16 変換する。:http://d.hatena.ne.jp/sirocco/20130416/1366103044]]
-[[Haskellで副作用を起こす(Win32 API によるUTF-16 ⇔ Shift-JIS 変換):http://d.hatena.ne.jp/sirocco/20130422/1366632065]]
-[[島ぶくろ Haskellプログラミング:http://saltheads.blog134.fc2.com/blog-category-16.html]]
-[[unsafePerformIOでunsafeなグローバル変数を作る。:http://d.hatena.ne.jp/napthats/20120426/1335416167]]
-[[Haskellの構造体をCと同期させる:http://tsubaki.hatenablog.com/entry/20110112/1294759187]]
-[[Haskell@Windowsのコンソールで日本語が文字化けする話の対策:http://tsubaki.hatenablog.com/entry/2013/02/20/090115]]
-[[How do I use Haskell's FFI on structs?:http://stackoverflow.com/questions/670221/how-do-i-use-haskells-ffi-on-structs]]
-http://www.cse.unsw.edu.au/~chak/haskell/ffi/ffi/ffise6.html
-http://darcs.haskell.org/testsuite/timeout/
--http://darcs.haskell.org/testsuite/timeout/WinCBindings.hsc
-https://bitbucket.org/dionthegod/fuzzywuzzy/src/cfd324244691/System/Win32/DebugProcess.hsc
-http://tanakh.jp/pub/pfi-seminar-2011-12-08.html#1
-http://www.ync-net.co.jp/~kaz/cgi-bin/WiLiKi/wiliki.cgi?try%2fthrow%2fcatch%2ffinally
-http://keqh.net/cookbook/
-[[Haskell の例外処理:http://tnomura9.exblog.jp/15094780/]]
-[[Haskell での例外処理:http://d.hatena.ne.jp/kazu-yamamoto/20120604/1338802792]], [[Haskellでの例外処理(その2):http://d.hatena.ne.jp/kazu-yamamoto/20120605/1338871044]]
-http://stackoverflow.com/questions/6009384/exception-handling-in-haskell
-http://stackoverflow.com/questions/2386210/how-to-get-a-pointer-value-in-haskell
-[[48時間でSchemeを書こう:http://ja.wikibooks.org/wiki/48%E6%99%82%E9%96%93%E3%81%A7Scheme%E3%82%92%E6%9B%B8%E3%81%93%E3%81%86]]
-[[Haskellの勉強をしていたら、Elixirのパイプライン演算子がF#由来であることを知った:http://d.hatena.ne.jp/ajiyoshi/20130127/1359284684]]
-[[ファンクタ, アプリカティブ, モナド:https://gist.github.com/kohyama/5856037]]
-[[lhs2TeX:http://www.andres-loeh.de/lhs2tex/]]
-[[Haskell Advent Calendar 2013 - Qiita [キータ]:http://qiita.com/advent-calendar/2013/haskell]]
-[[Theorem Prover Advent Calendar 2013 - Qiita [キータ]:http://qiita.com/advent-calendar/2013/theorem_prover]]
-[[Haskell for OCaml programmers:http://staff.science.uva.nl/~poss/haskell-for-ocaml-programmers.html]]
-[http://cx4a.org/posts/2014-06-03-solve-the-configurations-problem-for-haskell.html HaskellにおけるConfigurations Problemを解決する]
-[http://www.sampou.org/haskell/haskell2010-report-htja/ Haskell 2010 言語報告書]
--[http://www.sampou.org/haskell/haskell2010-report-htja/haskellch8.html Chapter 8 外部関数インターフェイス]
*Haskell で LaTeX [#b3f747e0]
**HaTeX [#vb17eba3]
-[http://www.haskell.org/haskellwiki/HaTeX HaTeX - HaskellWiki]
*[[fwdsumatrapdf>SumatraPDF/fwdsumatrapdf]] &aname(fwdsumatrapdf); [#j60bcd39]
**Haskell 版 [#cbd580e5]
The Glorious Glasgow Haskell Compilation System, version 7.8.2 で動作確認しています．~
The Glorious Glasgow Haskell Compilation System, version 7.8.3 で動作確認しています．~
Windows PowerShell またはコマンド プロンプトから以下のようにしてビルドします．~
hsc2hs fwdsumatrapdf_ffi.hsc
ghc -cpp fwdsumatrapdf.hs fwdsumatrapdf_ffi.hs
----
-fwdsumatrapdf_ffi.hsc
----
{-# LANGUAGE ForeignFunctionInterface #-}
module FwdSumatraPDF where
import Graphics.Win32.GDI.Types (HWND)
import Data.Bits ((.|.))
import System.Win32.Types (BOOL, BYTE, WORD, DWORD, UINT, LPARAM, LPBYTE, LPDWORD, LPWSTR, LPCWSTR, LPVOID, HANDLE)
import Foreign.C.String (CWString)
import Foreign.C.Types (CInt(..), CUInt(..), CWchar(..))
import Foreign.Ptr (Ptr, FunPtr)
import Foreign.Storable (alignment, sizeOf, peek, peekByteOff, poke, pokeByteOff, Storable)
#include <windows.h>
##ifdef x86_64_BUILD_ARCH
##define stdcall ccall
##endif
foreign import ccall unsafe "wchar.h wcscmp"
c_wcscmp :: CWString -> CWString -> IO CInt
foreign import ccall unsafe "wchar.h wcsrchr"
c_wcsrchr :: CWString -> CWchar -> IO (Ptr CWchar)
foreign import stdcall unsafe "windows.h GetWindowTextW"
getWindowTextW :: HWND -> LPWSTR -> CInt -> IO CInt
foreign import stdcall unsafe "wrapper"
mkEnumWindowsProc :: EnumWindowsProc -> IO (FunPtr EnumWindowsProc)
foreign import stdcall safe "windows.h EnumWindows"
enumWindows :: FunPtr EnumWindowsProc -> LPARAM -> IO BOOL
foreign import stdcall unsafe "windows.h CreateProcessW"
createProcessW :: LPCWSTR -> LPWSTR -> Ptr () -> Ptr () -> BOOL -> DWORD -> LPVOID -> LPCWSTR -> LPSTARTUPINFOW -> LPPROCESS_INFORMATION -> IO BOOL
foreign import stdcall unsafe "windows.h WaitForInputIdle"
waitForInputIdle :: HANDLE -> DWORD -> IO DWORD
foreign import stdcall unsafe "wrapper"
mkDdeCallback :: DdeCallback -> IO (FunPtr DdeCallback)
foreign import stdcall unsafe "ddeml.h DdeInitializeW"
ddeInitializeW :: LPDWORD -> FunPtr DdeCallback -> DWORD -> DWORD -> IO UINT
foreign import stdcall unsafe "ddeml.h DdeUninitialize"
ddeUninitialize :: DWORD -> IO BOOL
foreign import stdcall unsafe "ddeml.h DdeCreateStringHandleW"
ddeCreateStringHandleW :: DWORD -> LPWSTR -> CInt -> IO HANDLE
foreign import stdcall unsafe "ddeml.h DdeFreeStringHandle"
ddeFreeStringHandle :: DWORD -> HANDLE -> IO BOOL
foreign import stdcall unsafe "ddeml.h DdeGetLastError"
ddeGetLastError :: DWORD -> IO UINT
foreign import stdcall unsafe "ddeml.h DdeCreateDataHandle"
ddeCreateDataHandle :: DWORD -> LPBYTE -> DWORD -> DWORD -> HANDLE -> UINT -> UINT -> IO HANDLE
foreign import stdcall unsafe "ddeml.h DdeFreeDataHandle"
ddeFreeDataHandle :: HANDLE -> IO BOOL
foreign import stdcall unsafe "ddeml.h DdeClientTransaction"
ddeClientTransaction :: LPBYTE -> DWORD -> HANDLE -> HANDLE -> UINT -> UINT -> DWORD -> LPDWORD -> IO HANDLE
foreign import stdcall unsafe "ddeml.h DdeConnect"
ddeConnect :: DWORD -> HANDLE -> HANDLE -> Ptr () -> IO HANDLE
foreign import stdcall unsafe "ddeml.h DdeDisconnect"
ddeDisconnect :: HANDLE -> IO BOOL
aPPCMD_CLIENTONLY :: DWORD
aPPCMD_CLIENTONLY = 0x10
cP_WINUNICODE :: CInt
cP_WINUNICODE = 1200
cF_UNICODETEXT :: UINT
cF_UNICODETEXT = 13
xCLASS_FLAGS :: UINT
xCLASS_FLAGS = 0x4000
xTYP_EXECUTE :: UINT
xTYP_EXECUTE = 0x0050 .|. xCLASS_FLAGS
timeout :: DWORD
timeout = 10000
type EnumWindowsProc = HWND -> LPARAM -> IO BOOL
type DdeCallback = UINT -> UINT -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> DWORD -> DWORD -> IO HANDLE
type LPSTARTUPINFOW = Ptr STARTUPINFOW
data STARTUPINFOW = STARTUPINFOW
{ siCb :: DWORD
, siDesktop :: LPWSTR
, siTitle :: LPWSTR
, siX :: DWORD
, siY :: DWORD
, siXSize :: DWORD
, siYSize :: DWORD
, siXCountChars :: DWORD
, siYCountChars :: DWORD
, siFillAttribute :: DWORD
, siFlags :: DWORD
, siShowWindow :: WORD
, siStdInput :: HANDLE
, siStdOutput :: HANDLE
, siStdError :: HANDLE
} deriving (Show)
instance Storable STARTUPINFOW where
sizeOf = const #size STARTUPINFOW
alignment = sizeOf
poke buf si = do
(#poke STARTUPINFOW, cb) buf (siCb si)
(#poke STARTUPINFOW, lpDesktop) buf (siDesktop si)
(#poke STARTUPINFOW, lpTitle) buf (siTitle si)
(#poke STARTUPINFOW, dwX) buf (siX si)
(#poke STARTUPINFOW, dwY) buf (siY si)
(#poke STARTUPINFOW, dwXSize) buf (siXSize si)
(#poke STARTUPINFOW, dwYSize) buf (siYSize si)
(#poke STARTUPINFOW, dwXCountChars) buf (siXCountChars si)
(#poke STARTUPINFOW, dwYCountChars) buf (siYCountChars si)
(#poke STARTUPINFOW, dwFillAttribute) buf (siFillAttribute si)
(#poke STARTUPINFOW, dwFlags) buf (siFlags si)
(#poke STARTUPINFOW, wShowWindow) buf (siShowWindow si)
(#poke STARTUPINFOW, hStdInput) buf (siStdInput si)
(#poke STARTUPINFOW, hStdOutput) buf (siStdOutput si)
(#poke STARTUPINFOW, hStdError) buf (siStdError si)
peek buf = do
vcb <- (#peek STARTUPINFOW, cb) buf
vlpDesktop <- (#peek STARTUPINFOW, lpDesktop) buf
vlpTitle <- (#peek STARTUPINFOW, lpTitle) buf
vdwX <- (#peek STARTUPINFOW, dwX) buf
vdwY <- (#peek STARTUPINFOW, dwY) buf
vdwXSize <- (#peek STARTUPINFOW, dwXSize) buf
vdwYSize <- (#peek STARTUPINFOW, dwYSize) buf
vdwXCountChars <- (#peek STARTUPINFOW, dwXCountChars) buf
vdwYCountChars <- (#peek STARTUPINFOW, dwYCountChars) buf
vdwFillAttribute <- (#peek STARTUPINFOW, dwFillAttribute) buf
vdwFlags <- (#peek STARTUPINFOW, dwFlags) buf
vwShowWindow <- (#peek STARTUPINFOW, wShowWindow) buf
vhStdInput <- (#peek STARTUPINFOW, hStdInput) buf
vhStdOutput <- (#peek STARTUPINFOW, hStdOutput) buf
vhStdError <- (#peek STARTUPINFOW, hStdError) buf
return $ STARTUPINFOW {
siCb = vcb,
siDesktop = vlpDesktop,
siTitle = vlpTitle,
siX = vdwX,
siY = vdwY,
siXSize = vdwXSize,
siYSize = vdwYSize,
siXCountChars = vdwXCountChars,
siYCountChars = vdwYCountChars,
siFillAttribute = vdwFillAttribute,
siFlags = vdwFlags,
siShowWindow = vwShowWindow,
siStdInput = vhStdInput,
siStdOutput = vhStdOutput,
siStdError = vhStdError}
type LPPROCESS_INFORMATION = Ptr PROCESS_INFORMATION
data PROCESS_INFORMATION = PROCESS_INFORMATION
{ piProcess :: HANDLE
, piThread :: HANDLE
, piProcessId :: DWORD
, piThreadId :: DWORD
} deriving (Show)
instance Storable PROCESS_INFORMATION where
sizeOf = const #size PROCESS_INFORMATION
alignment = sizeOf
poke buf pi = do
(#poke PROCESS_INFORMATION, hProcess) buf (piProcess pi)
(#poke PROCESS_INFORMATION, hThread) buf (piThread pi)
(#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pi)
(#poke PROCESS_INFORMATION, dwThreadId) buf (piThreadId pi)
peek buf = do
vhProcess <- (#peek PROCESS_INFORMATION, hProcess) buf
vhThread <- (#peek PROCESS_INFORMATION, hThread) buf
vdwProcessId <- (#peek PROCESS_INFORMATION, dwProcessId) buf
vdwThreadId <- (#peek PROCESS_INFORMATION, dwThreadId) buf
return $ PROCESS_INFORMATION {
piProcess = vhProcess,
piThread = vhThread,
piProcessId = vdwProcessId,
piThreadId = vdwThreadId}
----
-fwdsumatrapdf.hs
----
-- vim: ts=4 sw=4 expandtab:
-- >hsc2hs fwdsumatrapdf_ffi.hsc
-- >ghc -cpp fwdsumatrapdf.hs fwdsumatrapdf_ffi.hs
module Main where
import System.Directory (doesFileExist)
import System.Environment (getArgs, getProgName)
import System.Exit (exitWith, ExitCode(ExitSuccess, ExitFailure))
import System.IO.Unsafe (unsafePerformIO)
import System.Win32.Registry (regOpenKeyEx, regQueryValue, regCloseKey, hKEY_LOCAL_MACHINE, kEY_QUERY_VALUE)
import System.Win32.Types (nullPtr, nullFinalHANDLE, DWORD, MbHANDLE)
import Graphics.Win32.GDI.Types (HWND)
import Data.IORef (newIORef, readIORef, writeIORef, IORef)
import Data.Maybe (fromJust, isJust)
import Control.Exception (bracket, catch, throwIO, SomeException)
import Control.Monad (return, when, void)
import Foreign.C.String (newCWString, withCWString, withCWStringLen, CWString)
import Foreign.C.Types (CWchar(..))
import Foreign.Ptr (castPtr)
import Foreign.Marshal.Alloc (alloca, free)
import Foreign.Marshal.Array (mallocArray)
import Foreign.Storable (sizeOf, peek)
import FwdSumatraPDF
{-# NOINLINE existSumatraHWND #-}
existSumatraHWND :: IORef Bool
existSumatraHWND = unsafePerformIO $ newIORef False
runSumatraPDF :: String -> IO Bool
runSumatraPDF pdf = do
enumwindowsproc <- mkEnumWindowsProc getSumatraHWND
enumWindows enumwindowsproc lParam
existSumatraPDF <- readIORef existSumatraHWND
case existSumatraPDF of
True -> return True
False -> findSumatraPDFInRegistry
where
lParam = 0
getSumatraHWND hwnd lParam = do
let maxSize = 1024
let latinCapitalLetterS = 0x53 -- 'S' == 0x53
bracket
(do windowText <- mallocArray (fromIntegral maxSize)
sumatrapdf <- newCWString "SumatraPDF"
return (windowText, sumatrapdf))
(\(windowText, sumatrapdf) -> do
free windowText
free sumatrapdf)
(\(windowText, sumatrapdf) -> do
getWindowTextW hwnd windowText maxSize
title <- c_wcsrchr windowText latinCapitalLetterS
if title /= nullPtr
then do
cmp <- c_wcscmp title sumatrapdf
if cmp == 0 then do
writeIORef existSumatraHWND True
return True
else do
return True
else do
return True)
findSumatraPDFInRegistry = do
let keyPath = "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\SumatraPDF.exe"
regKey <- regOpenKeyEx hKEY_LOCAL_MACHINE keyPath kEY_QUERY_VALUE
if regKey == nullFinalHANDLE
then return False
else do
sumatrapdfRegistry <- regQueryValue regKey Nothing
regCloseKey regKey
exist <- doesFileExist sumatrapdfRegistry
if exist then do
startSumatraPDF sumatrapdfRegistry
return True
else return False
startSumatraPDF file = do
let sumatrapdfCommandLine = "\"" ++ file ++ "\" " ++ "-reuse-instance" ++ " " ++ "\"" ++ pdf ++ "\""
withCWString sumatrapdfCommandLine $ \cmd -> do
alloca $ \p_si -> do
alloca $ \p_pi -> do
createProcessW nullPtr cmd nullPtr nullPtr False 0 nullPtr nullPtr p_si p_pi
pi <- peek p_pi
waitForInputIdle (piProcess pi) (fromIntegral timeout)
ddeExecute :: String -> String -> String -> IO (Maybe DWORD, MbHANDLE, MbHANDLE, MbHANDLE, MbHANDLE, MbHANDLE)
ddeExecute server topic command = do
bracket
(getIdInstance)
(\idInstance -> do
when
(isJust idInstance)
(void $ ddeUninitialize (fromJust idInstance)))
(\idInstance -> do
bracket
(getHszServer (fromJust idInstance) server)
(\hszServer -> do
when
(isJust hszServer)
(void $ ddeFreeStringHandle (fromJust idInstance) (fromJust hszServer)))
(\hszServer -> do
bracket
(getHszTopic (fromJust idInstance) topic)
(\hszTopic -> do
when
(isJust hszTopic)
(void $ ddeFreeStringHandle (fromJust idInstance) (fromJust hszTopic)))
(\hszTopic -> do
bracket
(getHConvClient (fromJust idInstance) (fromJust hszServer) (fromJust hszTopic))
(\hConvClient -> do
when
(isJust hConvClient)
(void $ ddeDisconnect (fromJust hConvClient)))
(\hConvClient -> do
bracket
(getHDdeData (fromJust idInstance) command)
(\hDdeData -> do
when
(isJust hDdeData)
(void $ ddeFreeDataHandle (fromJust hDdeData)))
(\hDdeData -> do
bracket
(getHDdeTransactionData (fromJust hDdeData) (fromJust hConvClient))
(\hDdeTransactionData -> do
when
(isJust hDdeTransactionData)
(void $ ddeFreeDataHandle (fromJust hDdeTransactionData)))
(\hDdeTransactionData -> do
return (idInstance, hszServer, hszTopic, hConvClient, hDdeData, hDdeTransactionData)))))))
where
getIdInstance = do
let sumatraDdeCallback uType uFmt hconv hsz1 hsza2 hdata dwData1 dwData2 = return nullPtr
alloca $ \p_idInstance -> do
ddecallback <- mkDdeCallback sumatraDdeCallback
e <- ddeInitializeW p_idInstance ddecallback aPPCMD_CLIENTONLY 0
idInstance <- peek p_idInstance
if idInstance == 0 || e /= 0 then do
throwIO $ userError "ddeInitializeW Error"
return Nothing
else return $ Just idInstance
getHszServer idInstance server = do
withCWString server $ \sv -> do
hszServer <- ddeCreateStringHandleW idInstance sv cP_WINUNICODE
if hszServer == nullPtr then do
throwIO $ userError "ddeCreateStringHandleW Error"
return Nothing
else return $ Just hszServer
getHszTopic idInstance topic = do
withCWString topic $ \tp -> do
hszTopic <- ddeCreateStringHandleW idInstance tp cP_WINUNICODE
if hszTopic == nullPtr then do
throwIO $ userError "ddeCreateStringHandleW Error"
return Nothing
else return $ Just hszTopic
getHConvClient idInstance hszServer hszTopic = do
hConvClient <- ddeConnect idInstance hszServer hszTopic nullPtr
if hConvClient == nullPtr then do
throwIO $ userError "ddeConnect Error"
return Nothing
else return $ Just hConvClient
getHDdeData idInstance command = do
withCWStringLen command $ \(cmd, len) -> do
hDdeData <- ddeCreateDataHandle idInstance (castPtr cmd) (fromIntegral ((len + 1) * (sizeOf (undefined :: CWchar)))) 0 nullPtr cF_UNICODETEXT 0
if hDdeData == nullPtr then do
throwIO $ userError "ddeCreateDataHandle Error"
return Nothing
else return $ Just hDdeData
getHDdeTransactionData hDdeData hConvClient = do
hDdeTransactionData <- ddeClientTransaction (castPtr hDdeData) (-1) hConvClient nullPtr 0 xTYP_EXECUTE timeout nullPtr
if hDdeTransactionData == nullPtr then do
throwIO $ userError "ddeClientTransaction Error"
return Nothing
else return $ Just hDdeTransactionData
main :: IO a
main = do
args <- getArgs
usage args
let pdf = args !! 0
let tex = args !! 1
let line = read $ args !! 2 :: Int
runSumatraPDF pdf `catch` printError
let active = 0
let forwardSearch = "[ForwardSearch(\"" ++ pdf ++ "\",\"" ++ tex ++ "\"," ++ show line ++ ",0,0," ++ show active ++ ")]"
ddeExecute "SUMATRA" "control" forwardSearch `catch` printError
exitWith ExitSuccess
where
usage args = do
case length args of
3 -> return ExitSuccess
_ -> do
progName <- getProgName
putStrLn $ "usage: " ++ progName ++ " pdffile texfile line"
exitWith $ ExitFailure 2
printError :: SomeException -> IO a
printError e = do
print e
exitWith $ ExitFailure 1
----
